diff options
Diffstat (limited to 'lib/Travelynx/Model')
| -rw-r--r-- | lib/Travelynx/Model/InTransit.pm | 904 | ||||
| -rwxr-xr-x | lib/Travelynx/Model/JourneyStatsCache.pm | 122 | ||||
| -rwxr-xr-x | lib/Travelynx/Model/Journeys.pm | 1785 | ||||
| -rw-r--r-- | lib/Travelynx/Model/Stations.pm | 199 | ||||
| -rw-r--r-- | lib/Travelynx/Model/Traewelling.pm | 243 | ||||
| -rw-r--r-- | lib/Travelynx/Model/Users.pm | 1160 |
6 files changed, 4413 insertions, 0 deletions
diff --git a/lib/Travelynx/Model/InTransit.pm b/lib/Travelynx/Model/InTransit.pm new file mode 100644 index 0000000..6278bad --- /dev/null +++ b/lib/Travelynx/Model/InTransit.pm @@ -0,0 +1,904 @@ +package Travelynx::Model::InTransit; + +# Copyright (C) 2020-2023 Birte Kristina Friesel +# +# SPDX-License-Identifier: AGPL-3.0-or-later + +use strict; +use warnings; +use 5.020; + +use DateTime; +use JSON; + +my %visibility_itoa = ( + 100 => 'public', + 80 => 'travelynx', + 60 => 'followers', + 30 => 'unlisted', + 10 => 'private', +); + +my %visibility_atoi = ( + public => 100, + travelynx => 80, + followers => 60, + unlisted => 30, + private => 10, +); + +sub _epoch { + my ($dt) = @_; + + return $dt ? $dt->epoch : 0; +} + +sub epoch_to_dt { + my ($epoch) = @_; + + # Bugs (and user errors) may lead to undefined timestamps. Set them to + # 1970-01-01 to avoid crashing and show obviously wrong data instead. + $epoch //= 0; + + return DateTime->from_epoch( + epoch => $epoch, + time_zone => 'Europe/Berlin', + locale => 'de-DE', + ); +} + +sub epoch_or_dt_to_dt { + my ($input) = @_; + + if ( ref($input) eq 'DateTime' ) { + return $input; + } + + return epoch_to_dt($input); +} + +sub new { + my ( $class, %opt ) = @_; + + return bless( \%opt, $class ); +} + +# merge [name, eva, data] from old_route into [name, undef, undef] from new_route. +# If new_route already has eva/data, it is kept as-is. +# changes new_route. +sub _merge_old_route { + my ( $self, %opt ) = @_; + my $db = $opt{db}; + my $uid = $opt{uid}; + my $new_route = $opt{route}; + + my $res_h = $db->select( 'in_transit', ['route'], { user_id => $uid } ) + ->expand->hash; + my $old_route = $res_h ? $res_h->{route} : []; + + for my $i ( 0 .. $#{$new_route} ) { + if ( $old_route->[$i] and $old_route->[$i][0] eq $new_route->[$i][0] ) { + $new_route->[$i][1] //= $old_route->[$i][1]; + if ( not keys %{ $new_route->[$i][2] // {} } ) { + $new_route->[$i][2] = $old_route->[$i][2]; + } + } + } + + return $new_route; +} + +sub add { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my $train = $opt{train}; + my $journey = $opt{journey}; + my $stop = $opt{stop}; + my $checkin_station_id = $opt{departure_eva}; + my $route = $opt{route}; + + my $json = JSON->new; + + if ($train) { + $db->insert( + 'in_transit', + { + user_id => $uid, + cancelled => $train->departure_is_cancelled ? 1 + : 0, + checkin_station_id => $checkin_station_id, + checkin_time => DateTime->now( time_zone => 'Europe/Berlin' ), + dep_platform => $train->platform, + train_type => $train->type, + train_line => $train->line_no, + train_no => $train->train_no, + train_id => $train->train_id, + sched_departure => $train->sched_departure, + real_departure => $train->departure, + route => $json->encode($route), + messages => $json->encode( + [ map { [ $_->[0]->epoch, $_->[1] ] } $train->messages ] + ), + data => JSON->new->encode( + { + rt => $train->departure_has_realtime ? 1 + : 0 + } + ), + } + ); + } + elsif ( $journey and $stop ) { + my @route; + my $product = $journey->product_at( $stop->loc->eva ) + // $journey->product; + for my $j_stop ( $journey->route ) { + push( + @route, + [ + $j_stop->loc->name, + $j_stop->loc->eva, + { + sched_arr => _epoch( $j_stop->sched_arr ), + sched_dep => _epoch( $j_stop->sched_dep ), + rt_arr => _epoch( $j_stop->rt_arr ), + rt_dep => _epoch( $j_stop->rt_dep ), + arr_delay => $j_stop->arr_delay, + dep_delay => $j_stop->dep_delay, + load => $j_stop->load + } + ] + ); + if ( defined $j_stop->tz_offset ) { + $route[-1][2]{tz_offset} = $j_stop->tz_offset; + } + } + $db->insert( + 'in_transit', + { + user_id => $uid, + cancelled => $stop->{dep_cancelled} + ? 1 + : 0, + checkin_station_id => $stop->loc->eva, + checkin_time => DateTime->now( time_zone => 'Europe/Berlin' ), + dep_platform => $stop->{platform}, + train_type => $product->type // q{}, + train_line => $product->line_no, + train_no => $product->number // q{}, + train_id => $journey->id, + sched_departure => $stop->{sched_dep}, + real_departure => $stop->{rt_dep} // $stop->{sched_dep}, + route => $json->encode( \@route ), + data => JSON->new->encode( { rt => $stop->{rt_dep} ? 1 : 0 } ), + } + ); + } + else { + die('neither train nor journey specified'); + } +} + +sub add_from_journey { + my ( $self, %opt ) = @_; + + my $journey = $opt{journey}; + my $db = $opt{db} // $self->{pg}->db; + + $db->insert( 'in_transit', $journey ); +} + +sub delete { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + + $db->delete( 'in_transit', { user_id => $uid } ); +} + +sub delete_incomplete_checkins { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + + return $db->delete( 'in_transit', + { checkin_time => { '<', $opt{earlier_than} } } )->rows; +} + +sub postprocess { + my ( $self, $ret ) = @_; + my $now = DateTime->now( time_zone => 'Europe/Berlin' ); + my $epoch = $now->epoch; + my @route = @{ $ret->{route} // [] }; + my @route_after; + my $dep_info; + my $is_after = 0; + + for my $station (@route) { + if ($is_after) { + push( @route_after, $station ); + } + if ( $ret->{dep_name} + and $station->[0] eq $ret->{dep_name} ) + { + $is_after = 1; + if ( @{$station} > 1 and not $dep_info ) { + $dep_info = $station->[2]; + } + } + } + + my $ts = $ret->{checkout_ts} // $ret->{checkin_ts}; + my $action_time = epoch_to_dt($ts); + + $ret->{checked_in} = !$ret->{cancelled}; + $ret->{timestamp} = $action_time; + $ret->{timestamp_delta} = $now->epoch - $action_time->epoch; + $ret->{boarding_countdown} = -1; + $ret->{sched_departure} = epoch_to_dt( $ret->{sched_dep_ts} ); + $ret->{real_departure} = epoch_to_dt( $ret->{real_dep_ts} ); + $ret->{sched_arrival} = epoch_to_dt( $ret->{sched_arr_ts} ); + $ret->{real_arrival} = epoch_to_dt( $ret->{real_arr_ts} ); + $ret->{route_after} = \@route_after; + $ret->{extra_data} = $ret->{data}; + $ret->{comment} = $ret->{user_data}{comment}; + + $ret->{visibility_str} + = $ret->{visibility} + ? $visibility_itoa{ $ret->{visibility} } + : 'default'; + $ret->{effective_visibility_str} + = $visibility_itoa{ $ret->{effective_visibility} }; + + my @parsed_messages; + for my $message ( @{ $ret->{messages} // [] } ) { + my ( $ts, $msg ) = @{$message}; + push( @parsed_messages, [ epoch_to_dt($ts), $msg ] ); + } + $ret->{messages} = [ reverse @parsed_messages ]; + + @parsed_messages = (); + for my $message ( @{ $ret->{extra_data}{qos_msg} // [] } ) { + my ( $ts, $msg ) = @{$message}; + push( @parsed_messages, [ epoch_to_dt($ts), $msg ] ); + } + $ret->{extra_data}{qos_msg} = [@parsed_messages]; + + if ( $dep_info and $dep_info->{sched_arr} ) { + $dep_info->{sched_arr} + = epoch_to_dt( $dep_info->{sched_arr} ); + $dep_info->{rt_arr} = epoch_to_dt( $dep_info->{rt_arr} ); + $dep_info->{rt_arr_countdown} = $ret->{boarding_countdown} + = $dep_info->{rt_arr}->epoch - $epoch; + } + + for my $station (@route_after) { + if ( @{$station} > 1 ) { + + # Note: $station->[2]{sched_arr} may already have been + # converted to a DateTime object. This can happen when a + # station is present several times in a train's route, e.g. + # for Frankfurt Flughafen in some nightly connections. + my $times = $station->[2] // {}; + for my $key (qw(sched_arr rt_arr sched_dep rt_dep)) { + if ( $times->{$key} ) { + $times->{$key} + = epoch_or_dt_to_dt( $times->{$key} ); + } + } + if ( $times->{sched_arr} and $times->{rt_arr} ) { + $times->{arr_delay} + = $times->{rt_arr}->epoch - $times->{sched_arr}->epoch; + } + if ( $times->{sched_arr} or $times->{rt_arr} ) { + $times->{arr} = $times->{rt_arr} || $times->{sched_arr}; + $times->{arr_countdown} = $times->{arr}->epoch - $epoch; + } + if ( $times->{sched_dep} and $times->{rt_dep} ) { + $times->{dep_delay} + = $times->{rt_dep}->epoch - $times->{sched_dep}->epoch; + } + if ( $times->{sched_dep} or $times->{rt_dep} ) { + $times->{dep} = $times->{rt_dep} || $times->{sched_dep}; + $times->{dep_countdown} = $times->{dep}->epoch - $epoch; + } + } + } + + $ret->{departure_countdown} = $ret->{real_departure}->epoch - $now->epoch; + + if ( $ret->{real_arr_ts} ) { + $ret->{arrival_countdown} = $ret->{real_arrival}->epoch - $now->epoch; + $ret->{journey_duration} + = $ret->{real_arrival}->epoch - $ret->{real_departure}->epoch; + $ret->{journey_completion} + = $ret->{journey_duration} + ? 1 - ( $ret->{arrival_countdown} / $ret->{journey_duration} ) + : 1; + if ( $ret->{journey_completion} > 1 ) { + $ret->{journey_completion} = 1; + } + elsif ( $ret->{journey_completion} < 0 ) { + $ret->{journey_completion} = 0; + } + + } + else { + $ret->{arrival_countdown} = undef; + $ret->{journey_duration} = undef; + $ret->{journey_completion} = undef; + } + + return $ret; +} + +sub get { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + + my $table = 'in_transit'; + + if ( $opt{with_timestamps} ) { + $table = 'in_transit_str'; + } + + my $res = $db->select( $table, '*', { user_id => $uid } ); + my $ret; + + if ( $opt{with_data} ) { + $ret = $res->expand->hash; + } + else { + $ret = $res->hash; + } + + if ( $opt{with_visibility} and $ret ) { + $ret->{visibility_str} + = $ret->{visibility} + ? $visibility_itoa{ $ret->{visibility} } + : 'default'; + $ret->{effective_visibility_str} + = $visibility_itoa{ $ret->{effective_visibility} }; + } + + if ( $opt{postprocess} and $ret ) { + return $self->postprocess($ret); + } + + return $ret; +} + +sub get_timeline { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + + my $where = { + follower_id => $uid, + effective_visibility => { '>=', 60 } + }; + + if ( $opt{short} ) { + return $db->select( + 'follows_in_transit', + [ + qw(followee_name train_type train_line train_no train_id dep_eva dep_name arr_eva arr_name) + ], + $where + )->hashes->each; + } + + my $res = $db->select( 'follows_in_transit', '*', $where ); + my $ret; + + if ( $opt{with_data} ) { + return map { $self->postprocess($_) } $res->expand->hashes->each; + } + else { + return $res->hashes->each; + } +} + +sub get_all_active { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + return $db->select( 'in_transit_str', '*', { cancelled => 0 } ) + ->hashes->each; +} + +sub get_checkout_station_id { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + + my $status = $db->select( 'in_transit', ['checkout_station_id'], + { user_id => $uid } )->hash; + + if ($status) { + return $status->{checkout_station_id}; + } + return; +} + +sub set_cancelled_destination { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my $cancelled_destination = $opt{cancelled_destination}; + + my $res_h = $db->select( 'in_transit', ['data'], { user_id => $uid } ) + ->expand->hash; + + my $data = $res_h ? $res_h->{data} : {}; + + $data->{cancelled_destination} = $cancelled_destination; + + $db->update( + 'in_transit', + { + checkout_station_id => undef, + checkout_time => undef, + arr_platform => undef, + sched_arrival => undef, + real_arrival => undef, + data => JSON->new->encode($data), + }, + { user_id => $uid } + ); +} + +sub set_arrival { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my $train = $opt{train}; + my $route = $opt{route}; + + $route = $self->_merge_old_route( + db => $db, + uid => $uid, + route => $route + ); + + my $json = JSON->new; + + $db->update( + 'in_transit', + { + checkout_time => DateTime->now( time_zone => 'Europe/Berlin' ), + arr_platform => $train->platform, + sched_arrival => $train->sched_arrival, + real_arrival => $train->arrival, + route => $json->encode($route), + messages => $json->encode( + [ map { [ $_->[0]->epoch, $_->[1] ] } $train->messages ] + ) + }, + { user_id => $uid } + ); +} + +sub set_arrival_eva { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my $checkout_station_id = $opt{arrival_eva}; + + $db->update( + 'in_transit', + { + checkout_station_id => $checkout_station_id, + }, + { user_id => $uid } + ); +} + +sub set_arrival_times { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my $sched_arr = $opt{sched_arrival}; + my $rt_arr = $opt{rt_arrival}; + + $db->update( + 'in_transit', + { + sched_arrival => $sched_arr, + real_arrival => $rt_arr + }, + { user_id => $uid } + ); +} + +sub set_polyline { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my $polyline = $opt{polyline}; + my $old_id = $opt{old_id}; + + my $coords = $polyline->{coords}; + my $from_eva = $polyline->{from_eva}; + my $to_eva = $polyline->{to_eva}; + + my $polyline_str = JSON->new->encode($coords); + + my $pl_res = $db->select( + 'polylines', + ['id'], + { + origin_eva => $from_eva, + destination_eva => $to_eva, + polyline => $polyline_str, + }, + { limit => 1 } + ); + + my $polyline_id; + if ( my $h = $pl_res->hash ) { + $polyline_id = $h->{id}; + } + else { + eval { + $polyline_id = $db->insert( + 'polylines', + { + origin_eva => $from_eva, + destination_eva => $to_eva, + polyline => $polyline_str + }, + { returning => 'id' } + )->hash->{id}; + }; + if ($@) { + $self->{log}->warn("add_route_timestamps: insert polyline: $@"); + } + } + if ( $polyline_id and ( not defined $old_id or $polyline_id != $old_id ) ) { + $self->set_polyline_id( + uid => $uid, + db => $db, + polyline_id => $polyline_id + ); + } + +} + +sub set_polyline_id { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my $polyline_id = $opt{polyline_id}; + + $db->update( + 'in_transit', + { polyline_id => $polyline_id }, + { user_id => $uid } + ); +} + +sub set_route_data { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my $route = $opt{route}; + my $delay_msg = $opt{delay_messages}; + my $qos_msg = $opt{qos_messages}; + my $him_msg = $opt{him_messages}; + + my $res_h = $db->select( 'in_transit', ['data'], { user_id => $uid } ) + ->expand->hash; + + my $data = $res_h ? $res_h->{data} : {}; + + $data->{delay_msg} = $opt{delay_messages}; + $data->{qos_msg} = $opt{qos_messages}; + $data->{him_msg} = $opt{him_messages}; + + # no need to merge $route, it already contains HAFAS data + $db->update( + 'in_transit', + { + route => JSON->new->encode($route), + data => JSON->new->encode($data) + }, + { user_id => $uid } + ); +} + +sub unset_arrival_data { + my ( $self, %opt ) = @_; + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + + $db->update( + 'in_transit', + { + checkout_time => undef, + arr_platform => undef, + sched_arrival => undef, + real_arrival => undef, + }, + { user_id => $uid } + ); +} + +sub update_departure { + my ( $self, %opt ) = @_; + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my $dep_eva = $opt{dep_eva}; + my $arr_eva = $opt{arr_eva}; + my $train = $opt{train}; + my $route = $opt{route}; + my $json = JSON->new; + + $route = $self->_merge_old_route( + db => $db, + uid => $uid, + route => $route + ); + + # selecting on user_id and train_no avoids a race condition if a user checks + # into a new train while we are fetching data for their previous journey. In + # this case, the new train would receive data from the previous journey. + $db->update( + 'in_transit', + { + dep_platform => $train->platform, + real_departure => $train->departure, + route => $json->encode($route), + messages => $json->encode( + [ map { [ $_->[0]->epoch, $_->[1] ] } $train->messages ] + ), + }, + { + user_id => $uid, + train_no => $train->train_no, + checkin_station_id => $dep_eva, + checkout_station_id => $arr_eva, + } + ); +} + +sub update_departure_cancelled { + my ( $self, %opt ) = @_; + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my $dep_eva = $opt{dep_eva}; + my $arr_eva = $opt{arr_eva}; + my $train = $opt{train}; + + # depending on the amount of users in transit, some time may + # have passed between fetching $entry from the database and + # now. Ensure that the user is still checked into this train + # by selecting on uid, train no, and checkin/checkout station ID. + my $rows = $db->update( + 'in_transit', + { + cancelled => 1, + }, + { + user_id => $uid, + train_no => $train->train_no, + checkin_station_id => $dep_eva, + checkout_station_id => $arr_eva, + } + )->rows; + + return $rows; +} + +sub update_departure_hafas { + my ( $self, %opt ) = @_; + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my $dep_eva = $opt{dep_eva}; + my $arr_eva = $opt{arr_eva}; + my $journey = $opt{journey}; + my $stop = $opt{stop}; + my $json = JSON->new; + + # selecting on user_id and train_no avoids a race condition if a user checks + # into a new train while we are fetching data for their previous journey. In + # this case, the new train would receive data from the previous journey. + $db->update( + 'in_transit', + { + real_departure => $stop->{rt_dep}, + }, + { + user_id => $uid, + train_id => $journey->id, + checkin_station_id => $dep_eva, + checkout_station_id => $arr_eva, + } + ); +} + +sub update_arrival { + my ( $self, %opt ) = @_; + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my $dep_eva = $opt{dep_eva}; + my $arr_eva = $opt{arr_eva}; + my $train = $opt{train}; + my $route = $opt{route}; + my $json = JSON->new; + + $route = $self->_merge_old_route( + db => $db, + uid => $uid, + route => $route + ); + + # selecting on user_id, train_no and checkout_station_id avoids a + # race condition when a user checks into a new train or changes + # their destination station while we are fetching times based on no + # longer valid database entries. + my $rows = $db->update( + 'in_transit', + { + arr_platform => $train->platform, + sched_arrival => $train->sched_arrival, + real_arrival => $train->arrival, + route => $json->encode($route), + messages => $json->encode( + [ map { [ $_->[0]->epoch, $_->[1] ] } $train->messages ] + ), + }, + { + user_id => $uid, + train_no => $train->train_no, + checkin_station_id => $dep_eva, + checkout_station_id => $arr_eva, + } + )->rows; + + return $rows; +} + +sub update_arrival_hafas { + my ( $self, %opt ) = @_; + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my $dep_eva = $opt{dep_eva}; + my $arr_eva = $opt{arr_eva}; + my $journey = $opt{journey}; + my $stop = $opt{stop}; + my $json = JSON->new; + + # TODO use old rt data if available + my @route; + for my $j_stop ( $journey->route ) { + push( + @route, + [ + $j_stop->loc->name, + $j_stop->loc->eva, + { + sched_arr => _epoch( $j_stop->sched_arr ), + sched_dep => _epoch( $j_stop->sched_dep ), + rt_arr => _epoch( $j_stop->rt_arr ), + rt_dep => _epoch( $j_stop->rt_dep ), + arr_delay => $j_stop->arr_delay, + dep_delay => $j_stop->dep_delay, + load => $j_stop->load + } + ] + ); + if ( defined $j_stop->tz_offset ) { + $route[-1][2]{tz_offset} = $j_stop->tz_offset; + } + } + + my $res_h = $db->select( 'in_transit', ['route'], { user_id => $uid } ) + ->expand->hash; + my $old_route = $res_h ? $res_h->{route} : []; + + for my $i ( 0 .. $#route ) { + if ( $old_route->[$i] and $old_route->[$i][1] == $route[$i][1] ) { + for my $k (qw(rt_arr rt_dep arr_delay dep_delay)) { + $route[$i][2]{$k} //= $old_route->[$i][2]{$k}; + } + } + } + + # selecting on user_id and train_no avoids a race condition if a user checks + # into a new train while we are fetching data for their previous journey. In + # this case, the new train would receive data from the previous journey. + $db->update( + 'in_transit', + { + real_arrival => $stop->{rt_arr}, + route => $json->encode( [@route] ), + }, + { + user_id => $uid, + train_id => $journey->id, + checkin_station_id => $dep_eva, + checkout_station_id => $arr_eva, + } + ); +} + +sub update_data { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my $new_data = $opt{data} // {}; + + my $res_h = $db->select( 'in_transit', ['data'], { user_id => $uid } ) + ->expand->hash; + + my $data = $res_h ? $res_h->{data} : {}; + + while ( my ( $k, $v ) = each %{$new_data} ) { + $data->{$k} = $v; + } + + $db->update( + 'in_transit', + { data => JSON->new->encode($data) }, + { user_id => $uid } + ); +} + +sub update_user_data { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my $new_data = $opt{user_data} // {}; + + my $res_h = $db->select( 'in_transit', ['user_data'], { user_id => $uid } ) + ->expand->hash; + + my $data = $res_h ? $res_h->{user_data} : {}; + + while ( my ( $k, $v ) = each %{$new_data} ) { + $data->{$k} = $v; + } + + $db->update( + 'in_transit', + { user_data => JSON->new->encode($data) }, + { user_id => $uid } + ); +} + +sub update_visibility { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + + my $visibility; + + if ( $opt{visibility} and $visibility_atoi{ $opt{visibility} } ) { + $visibility = $visibility_atoi{ $opt{visibility} }; + } + + $db->update( + 'in_transit', + { visibility => $visibility }, + { user_id => $uid } + ); +} + +1; diff --git a/lib/Travelynx/Model/JourneyStatsCache.pm b/lib/Travelynx/Model/JourneyStatsCache.pm new file mode 100755 index 0000000..d23eb04 --- /dev/null +++ b/lib/Travelynx/Model/JourneyStatsCache.pm @@ -0,0 +1,122 @@ +package Travelynx::Model::JourneyStatsCache; + +# Copyright (C) 2020-2023 Birte Kristina Friesel +# +# SPDX-License-Identifier: AGPL-3.0-or-later + +use strict; +use warnings; +use 5.020; +use utf8; + +import JSON; + +sub new { + my ( $class, %opt ) = @_; + + return bless( \%opt, $class ); +} + +sub add { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + + eval { + $db->insert( + 'journey_stats', + { + user_id => $opt{uid}, + year => $opt{year}, + month => $opt{month}, + data => JSON->new->encode( $opt{stats} ), + } + ); + }; + if ( my $err = $@ ) { + if ( $err =~ m{duplicate key value violates unique constraint} ) { + + # If a user opens the same history page several times in + # short succession, there is a race condition where several + # Mojolicious workers execute this helper, notice that there is + # no up-to-date history, compute it, and insert it using the + # statement above. This will lead to a uniqueness violation + # in each successive insert. However, this is harmless, and + # thus ignored. + } + else { + # Otherwise we probably have a problem. + die($@); + } + } +} + +sub get { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + + my $stats = $db->select( + 'journey_stats', + ['data'], + { + user_id => $opt{uid}, + year => $opt{year}, + month => $opt{month} + } + )->expand->hash; + + return $stats->{data}; +} + +# Statistics are partitioned by real_departure, which must be provided +# when calling this function e.g. after journey deletion or editing. +# If a joureny's real_departure has been edited, this function must be +# called twice: once with the old and once with the new value. +sub invalidate { + my ( $self, %opt ) = @_; + + my $ts = $opt{ts}; + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + + $db->delete( + 'journey_stats', + { + user_id => $uid, + year => $ts->year, + month => $ts->month, + } + ); + $db->delete( + 'journey_stats', + { + user_id => $uid, + year => $ts->year, + month => 0, + } + ); +} + +sub get_yyyymm_having_stats { + my ( $self, %opt ) = @_; + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my $res = $db->select( + 'journey_stats', + [ 'year', 'month' ], + { user_id => $uid }, + { order_by => { -asc => [ 'year', 'month' ] } } + ); + + my @ret; + for my $row ( $res->hashes->each ) { + if ( $row->{month} != 0 ) { + push( @ret, [ $row->{year}, $row->{month} ] ); + } + } + + return @ret; +} + +1; diff --git a/lib/Travelynx/Model/Journeys.pm b/lib/Travelynx/Model/Journeys.pm new file mode 100755 index 0000000..97c4681 --- /dev/null +++ b/lib/Travelynx/Model/Journeys.pm @@ -0,0 +1,1785 @@ +package Travelynx::Model::Journeys; + +# Copyright (C) 2020-2023 Birte Kristina Friesel +# +# SPDX-License-Identifier: AGPL-3.0-or-later + +use GIS::Distance; +use List::MoreUtils qw(after_incl before_incl); + +use strict; +use warnings; +use 5.020; +use utf8; + +use DateTime; +use JSON; + +my %visibility_itoa = ( + 100 => 'public', + 80 => 'travelynx', + 60 => 'followers', + 30 => 'unlisted', + 10 => 'private', +); + +my %visibility_atoi = ( + public => 100, + travelynx => 80, + followers => 60, + unlisted => 30, + private => 10, +); + +my @month_name + = ( + qw(Januar Februar März April Mai Juni Juli August September Oktober November Dezember) + ); + +sub epoch_to_dt { + my ($epoch) = @_; + + # Bugs (and user errors) may lead to undefined timestamps. Set them to + # 1970-01-01 to avoid crashing and show obviously wrong data instead. + $epoch //= 0; + + return DateTime->from_epoch( + epoch => $epoch, + time_zone => 'Europe/Berlin', + locale => 'de-DE', + ); +} + +sub min_to_human { + my ( $self, $minutes ) = @_; + + my @ret; + + if ( $minutes >= 14 * 24 * 60 ) { + push( @ret, int( $minutes / ( 7 * 24 * 60 ) ) . ' Wochen' ); + } + elsif ( $minutes >= 7 * 24 * 60 ) { + push( @ret, '1 Woche' ); + } + $minutes %= 7 * 24 * 60; + + if ( $minutes >= 2 * 24 * 60 ) { + push( @ret, int( $minutes / ( 24 * 60 ) ) . ' Tage' ); + } + elsif ( $minutes >= 24 * 60 ) { + push( @ret, '1 Tag' ); + } + $minutes %= 24 * 60; + + if ( $minutes >= 2 * 60 ) { + push( @ret, int( $minutes / 60 ) . ' Stunden' ); + } + elsif ( $minutes >= 60 ) { + push( @ret, '1 Stunde' ); + } + $minutes %= 60; + + if ( $minutes >= 2 ) { + push( @ret, "$minutes Minuten" ); + } + elsif ($minutes) { + push( @ret, '1 Minute' ); + } + + if ( @ret == 0 ) { + return '0 Minuten'; + } + + if ( @ret == 1 ) { + return $ret[0]; + } + + my $last = pop(@ret); + return join( ', ', @ret ) . " und $last"; +} + +sub new { + my ( $class, %opt ) = @_; + + return bless( \%opt, $class ); +} + +sub stats_cache { + my ($self) = @_; + return $self->{stats_cache}; +} + +# Returns (journey id, error) +# Must be called during a transaction. +# Must perform a rollback on error. +sub add { + my ( $self, %opt ) = @_; + + my $db = $opt{db}; + my $uid = $opt{uid}; + my $now = DateTime->now( time_zone => 'Europe/Berlin' ); + my $dep_station = $self->{stations}->search( $opt{dep_station} ); + my $arr_station = $self->{stations}->search( $opt{arr_station} ); + + if ( not $dep_station ) { + return ( undef, 'Unbekannter Startbahnhof' ); + } + if ( not $arr_station ) { + return ( undef, 'Unbekannter Zielbahnhof' ); + } + + my $daily_journey_count = $db->select( + 'journeys_str', + 'count(*) as count', + { + user_id => $uid, + real_dep_ts => { + -between => [ + $opt{rt_departure}->clone->subtract( days => 1 )->epoch, + $opt{rt_departure}->epoch + ], + }, + } + )->hash->{count}; + + if ( $daily_journey_count >= 100 ) { + return ( undef, +"In den 24 Stunden vor der angegebenen Abfahrtszeit wurden ${daily_journey_count} weitere Fahrten angetreten. Das kann nicht stimmen." + ); + } + + my $route_has_start = 0; + my $route_has_stop = 0; + + for my $station ( @{ $opt{route} || [] } ) { + if ( $station eq $dep_station->{name} + or $station eq $dep_station->{ds100} ) + { + $route_has_start = 1; + } + if ( $station eq $arr_station->{name} + or $station eq $arr_station->{ds100} ) + { + $route_has_stop = 1; + } + } + + my @route; + + if ( not $route_has_start ) { + push( @route, [ $dep_station->{name}, $dep_station->{eva}, {} ] ); + } + + if ( $opt{route} ) { + my @unknown_stations; + for my $station ( @{ $opt{route} } ) { + my $station_info = $self->{stations}->search($station); + if ($station_info) { + push( @route, + [ $station_info->{name}, $station_info->{eva}, {} ] ); + } + else { + push( @route, [ $station, undef, {} ] ); + push( @unknown_stations, $station ); + } + } + + if ( not $opt{lax} ) { + if ( @unknown_stations == 1 ) { + return ( undef, + "Unbekannter Unterwegshalt: $unknown_stations[0]" ); + } + elsif (@unknown_stations) { + return ( undef, + 'Unbekannte Unterwegshalte: ' + . join( ', ', @unknown_stations ) ); + } + } + } + + if ( not $route_has_stop ) { + push( @route, [ $arr_station->{name}, $arr_station->{eva}, {} ] ); + } + + my $entry = { + user_id => $uid, + train_type => $opt{train_type}, + train_line => $opt{train_line}, + train_no => $opt{train_no}, + train_id => 'manual', + checkin_station_id => $dep_station->{eva}, + checkin_time => $now, + sched_departure => $opt{sched_departure}, + real_departure => $opt{rt_departure}, + checkout_station_id => $arr_station->{eva}, + sched_arrival => $opt{sched_arrival}, + real_arrival => $opt{rt_arrival}, + checkout_time => $now, + edited => 0x3fff, + cancelled => $opt{cancelled} ? 1 : 0, + route => JSON->new->encode( \@route ), + }; + + if ( $opt{comment} ) { + $entry->{user_data} + = JSON->new->encode( { comment => $opt{comment} } ); + } + + my $journey_id = undef; + eval { + $journey_id + = $db->insert( 'journeys', $entry, { returning => 'id' } ) + ->hash->{id}; + $self->stats_cache->invalidate( + ts => $opt{rt_departure}, + db => $db, + uid => $uid + ); + }; + + if ($@) { + $self->{log}->error("add_journey($uid): $@"); + return ( undef, 'add_journey failed: ' . $@ ); + } + + return ( $journey_id, undef ); +} + +sub add_from_in_transit { + my ( $self, %opt ) = @_; + my $db = $opt{db}; + my $journey = $opt{journey}; + + delete $journey->{data}; + $journey->{edited} = 0; + $journey->{checkout_time} = DateTime->now( time_zone => 'Europe/Berlin' ); + + return $db->insert( 'journeys', $journey, { returning => 'id' } ) + ->hash->{id}; +} + +sub update { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + my $journey_id = $opt{id}; + + my $rows; + + my $journey = $self->get_single( + uid => $uid, + db => $db, + journey_id => $journey_id, + with_datetime => 1, + ); + + eval { + if ( exists $opt{from_name} ) { + my $from_station = $self->{stations}->search( $opt{from_name} ); + if ( not $from_station ) { + die("Unbekannter Startbahnhof\n"); + } + $rows = $db->update( + 'journeys', + { + checkin_station_id => $from_station->{eva}, + edited => $journey->{edited} | 0x0004, + }, + { + id => $journey_id, + } + )->rows; + } + if ( exists $opt{to_name} ) { + my $to_station = $self->{stations}->search( $opt{to_name} ); + if ( not $to_station ) { + die("Unbekannter Zielbahnhof\n"); + } + $rows = $db->update( + 'journeys', + { + checkout_station_id => $to_station->{eva}, + edited => $journey->{edited} | 0x0400, + }, + { + id => $journey_id, + } + )->rows; + } + if ( exists $opt{sched_departure} ) { + $rows = $db->update( + 'journeys', + { + sched_departure => $opt{sched_departure}, + edited => $journey->{edited} | 0x0001, + }, + { + id => $journey_id, + } + )->rows; + } + if ( exists $opt{rt_departure} ) { + $rows = $db->update( + 'journeys', + { + real_departure => $opt{rt_departure}, + edited => $journey->{edited} | 0x0002, + }, + { + id => $journey_id, + } + )->rows; + + # stats are partitioned by rt_departure -> both the cache for + # the old value (see bottom of this function) and the new value + # (here) must be invalidated. + $self->stats_cache->invalidate( + ts => $opt{rt_departure}, + db => $db, + uid => $uid, + ); + } + if ( exists $opt{sched_arrival} ) { + $rows = $db->update( + 'journeys', + { + sched_arrival => $opt{sched_arrival}, + edited => $journey->{edited} | 0x0100, + }, + { + id => $journey_id, + } + )->rows; + } + if ( exists $opt{rt_arrival} ) { + $rows = $db->update( + 'journeys', + { + real_arrival => $opt{rt_arrival}, + edited => $journey->{edited} | 0x0200, + }, + { + id => $journey_id, + } + )->rows; + } + if ( exists $opt{route} ) { + my @new_route = map { [ $_, undef, {} ] } @{ $opt{route} }; + $rows = $db->update( + 'journeys', + { + route => JSON->new->encode( \@new_route ), + edited => $journey->{edited} | 0x0010, + }, + { + id => $journey_id, + } + )->rows; + } + if ( exists $opt{cancelled} ) { + $rows = $db->update( + 'journeys', + { + cancelled => $opt{cancelled}, + edited => $journey->{edited} | 0x0020, + }, + { + id => $journey_id, + } + )->rows; + } + if ( exists $opt{comment} ) { + $journey->{user_data}{comment} = $opt{comment}; + $rows = $db->update( + 'journeys', + { + user_data => JSON->new->encode( $journey->{user_data} ), + }, + { + id => $journey_id, + } + )->rows; + } + if ( not defined $rows ) { + die("Invalid update key\n"); + } + }; + + if ($@) { + $self->{log}->error("update($journey_id): $@"); + return "update($journey_id): $@"; + } + if ( $rows == 1 ) { + $self->stats_cache->invalidate( + ts => $journey->{rt_departure}, + db => $db, + uid => $uid, + ); + return undef; + } + return "update($journey_id): did not match any journey part"; +} + +sub delete { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my $journey_id = $opt{id}; + my $checkin_epoch = $opt{checkin}; + my $checkout_epoch = $opt{checkout}; + + my @journeys = $self->get( + uid => $uid, + journey_id => $journey_id + ); + if ( @journeys == 0 ) { + return 'Journey not found'; + } + my $journey = $journeys[0]; + + # Double-check (comparing both ID and action epoch) to make sure we + # are really deleting the right journey and the user isn't just + # playing around with POST requests. + if ( $journey->{id} != $journey_id + or $journey->{checkin_ts} != $checkin_epoch + or $journey->{checkout_ts} != $checkout_epoch ) + { + return 'Invalid journey data'; + } + + my $rows; + eval { + $rows = $db->delete( + 'journeys', + { + user_id => $uid, + id => $journey_id, + } + )->rows; + }; + + if ($@) { + $self->{log}->error("Delete($uid, $journey_id): $@"); + return 'DELETE failed: ' . $@; + } + + if ( $rows == 1 ) { + $self->stats_cache->invalidate( + ts => epoch_to_dt( $journey->{rt_dep_ts} ), + uid => $uid + ); + return undef; + } + return sprintf( 'Deleted %d rows, expected 1', $rows ); +} + +# Used for undo (move journey entry to in_transit) +sub pop { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db}; + my $journey_id = $opt{journey_id}; + + my $journey = $db->select( + 'journeys', + '*', + { + user_id => $uid, + id => $journey_id + } + )->hash; + + $db->delete( + 'journeys', + { + user_id => $uid, + id => $journey_id + } + ); + + return $journey; +} + +sub get { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + + # If get is called from inside a transaction, db + # specifies the database handle performing the transaction. + # Otherwise, we grab a fresh one. + my $db = $opt{db} // $self->{pg}->db; + + my @select + = ( + qw(journey_id train_type train_line train_no checkin_ts sched_dep_ts real_dep_ts dep_eva dep_ds100 dep_name dep_lat dep_lon checkout_ts sched_arr_ts real_arr_ts arr_eva arr_ds100 arr_name arr_lat arr_lon cancelled edited route messages user_data visibility effective_visibility) + ); + my %where = ( + user_id => $uid, + cancelled => 0 + ); + my %order = ( + order_by => { + -desc => 'real_dep_ts', + } + ); + + if ( $opt{cancelled} ) { + $where{cancelled} = 1; + } + + if ( $opt{limit} ) { + $order{limit} = $opt{limit}; + } + + if ( $opt{sched_dep_ts} ) { + $where{sched_dep_ts} = $opt{sched_dep_ts}; + } + + if ( $opt{journey_id} ) { + $where{journey_id} = $opt{journey_id}; + delete $where{cancelled}; + } + elsif ( $opt{after} and $opt{before} ) { + $where{real_dep_ts} + = { -between => [ $opt{after}->epoch, $opt{before}->epoch, ] }; + } + elsif ( $opt{after} ) { + $where{real_dep_ts} = { '>=', $opt{after}->epoch }; + } + elsif ( $opt{before} ) { + $where{real_dep_ts} = { '<=', $opt{before}->epoch }; + } + + if ( $opt{with_polyline} ) { + push( @select, 'polyline' ); + } + + if ( $opt{min_visibility} ) { + if ( $visibility_atoi{ $opt{min_visibility} } ) { + $opt{min_visibility} = $visibility_atoi{ $opt{min_visibility} }; + } + $where{effective_visibility} = { '>=', $opt{min_visibility} }; + } + + my @travels; + + my $res = $db->select( 'journeys_str', \@select, \%where, \%order ); + + for my $entry ( $res->expand->hashes->each ) { + + my $ref = { + id => $entry->{journey_id}, + type => $entry->{train_type}, + line => $entry->{train_line}, + no => $entry->{train_no}, + from_eva => $entry->{dep_eva}, + from_ds100 => $entry->{dep_ds100}, + from_name => $entry->{dep_name}, + from_latlon => [ $entry->{dep_lat}, $entry->{dep_lon} ], + checkin_ts => $entry->{checkin_ts}, + sched_dep_ts => $entry->{sched_dep_ts}, + rt_dep_ts => $entry->{real_dep_ts}, + to_eva => $entry->{arr_eva}, + to_ds100 => $entry->{arr_ds100}, + to_name => $entry->{arr_name}, + to_latlon => [ $entry->{arr_lat}, $entry->{arr_lon} ], + checkout_ts => $entry->{checkout_ts}, + sched_arr_ts => $entry->{sched_arr_ts}, + rt_arr_ts => $entry->{real_arr_ts}, + messages => $entry->{messages}, + route => $entry->{route}, + edited => $entry->{edited}, + user_data => $entry->{user_data}, + visibility => $entry->{visibility}, + effective_visibility => $entry->{effective_visibility}, + }; + + if ( $opt{with_visibility} ) { + $ref->{visibility_str} + = $ref->{visibility} + ? $visibility_itoa{ $ref->{visibility} } + : 'default'; + $ref->{effective_visibility_str} + = $visibility_itoa{ $ref->{effective_visibility} }; + } + + if ( $opt{with_polyline} ) { + $ref->{polyline} = $entry->{polyline}; + } + + if ( $opt{with_datetime} ) { + $ref->{checkin} = epoch_to_dt( $ref->{checkin_ts} ); + $ref->{sched_departure} + = epoch_to_dt( $ref->{sched_dep_ts} ); + $ref->{rt_departure} = epoch_to_dt( $ref->{rt_dep_ts} ); + $ref->{checkout} = epoch_to_dt( $ref->{checkout_ts} ); + $ref->{sched_arrival} = epoch_to_dt( $ref->{sched_arr_ts} ); + $ref->{rt_arrival} = epoch_to_dt( $ref->{rt_arr_ts} ); + for my $stop ( @{ $ref->{route} } ) { + for my $k (qw(rt_arr rt_dep sched_arr sched_dep)) { + if ( $stop->[2]{$k} ) { + $stop->[2]{$k} = epoch_to_dt( $stop->[2]{$k} ); + } + } + } + } + + if ( $opt{verbose} ) { + my $rename = $self->{renamed_station}; + for my $stop ( @{ $ref->{route} } ) { + if ( $stop->[0] =~ m{^Betriebsstelle nicht bekannt (\d+)$} ) { + if ( my $s = $self->{stations}->get_by_eva($1) ) { + $stop->[0] = $s->{name}; + } + } + if ( $rename->{ $stop->[0] } ) { + $stop->[0] = $rename->{ $stop->[0] }; + } + } + $ref->{cancelled} = $entry->{cancelled}; + my @parsed_messages; + for my $message ( @{ $ref->{messages} // [] } ) { + my ( $ts, $msg ) = @{$message}; + push( @parsed_messages, [ epoch_to_dt($ts), $msg ] ); + } + $ref->{messages} = [ reverse @parsed_messages ]; + $ref->{sched_duration} + = defined $ref->{sched_arr_ts} + ? $ref->{sched_arr_ts} - $ref->{sched_dep_ts} + : undef; + $ref->{rt_duration} + = defined $ref->{rt_arr_ts} + ? $ref->{rt_arr_ts} - $ref->{rt_dep_ts} + : undef; + my ( $km_polyline, $km_route, $km_beeline, $skip ) + = $self->get_travel_distance($ref); + $ref->{km_route} = $km_polyline || $km_route; + $ref->{skip_route} = $km_polyline ? 0 : $skip; + $ref->{km_beeline} = $km_beeline; + $ref->{skip_beeline} = $skip; + my $kmh_divisor + = ( $ref->{rt_duration} // $ref->{sched_duration} // 999999 ) + / 3600; + $ref->{kmh_route} + = $kmh_divisor ? $ref->{km_route} / $kmh_divisor : -1; + $ref->{kmh_beeline} + = $kmh_divisor + ? $ref->{km_beeline} / $kmh_divisor + : -1; + } + + push( @travels, $ref ); + } + + return @travels; +} + +sub get_single { + my ( $self, %opt ) = @_; + + $opt{cancelled} = 'any'; + my @journeys = $self->get(%opt); + if ( @journeys == 0 ) { + return undef; + } + + return $journeys[0]; +} + +sub get_latest { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + + my $latest_successful = $db->select( + 'journeys_str', + '*', + { + user_id => $uid, + cancelled => 0 + }, + { + order_by => { -desc => 'real_dep_ts' }, + limit => 1 + } + )->expand->hash; + + if ($latest_successful) { + $latest_successful->{visibility_str} + = $latest_successful->{visibility} + ? $visibility_itoa{ $latest_successful->{visibility} } + : 'default'; + $latest_successful->{effective_visibility_str} + = $visibility_itoa{ $latest_successful->{effective_visibility} }; + } + + my $latest = $db->select( + 'journeys_str', + '*', + { + user_id => $uid, + }, + { + order_by => { -desc => 'journey_id' }, + limit => 1 + } + )->expand->hash; + + if ($latest) { + $latest->{visibility_str} + = $latest->{visibility} + ? $visibility_itoa{ $latest->{visibility} } + : 'default'; + $latest->{effective_visibility_str} + = $visibility_itoa{ $latest->{effective_visibility} }; + } + + return ( $latest_successful, $latest ); +} + +sub get_oldest_ts { + my ( $self, %opt ) = @_; + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + + my $res_h = $db->select( + 'journeys_str', + ['sched_dep_ts'], + { + user_id => $uid, + }, + { + limit => 1, + order_by => { + -asc => 'real_dep_ts', + }, + } + )->hash; + + if ($res_h) { + return epoch_to_dt( $res_h->{sched_dep_ts} ); + } + return undef; +} + +sub get_latest_checkout_station_id { + my ( $self, %opt ) = @_; + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + + my $res_h = $db->select( + 'journeys', + ['checkout_station_id'], + { + user_id => $uid, + cancelled => 0 + }, + { + limit => 1, + order_by => { -desc => 'real_departure' } + } + )->hash; + + if ( not $res_h ) { + return; + } + + return $res_h->{checkout_station_id}; +} + +sub get_latest_checkout_stations { + my ( $self, %opt ) = @_; + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my $limit = $opt{limit} // 5; + + my $res = $db->select( + 'journeys_str', + [ 'arr_name', 'arr_eva', 'train_id' ], + { + user_id => $uid, + cancelled => 0 + }, + { + limit => $limit, + order_by => { -desc => 'journey_id' } + } + ); + + if ( not $res ) { + return; + } + + my @ret; + + while ( my $row = $res->hash ) { + push( + @ret, + { + name => $row->{arr_name}, + eva => $row->{arr_eva}, + hafas => ( $row->{train_id} =~ m{[|]} ? 1 : 0 ), + } + ); + } + + return @ret; +} + +sub get_nav_years { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + + my $res = $db->select( + 'journeys', + 'distinct extract(year from real_departure) as year', + { user_id => $uid }, + { order_by => { -asc => 'year' } } + ); + + my @ret; + for my $row ( $res->hashes->each ) { + push( @ret, [ $row->{year}, $row->{year} ] ); + } + return @ret; +} + +sub get_years { + my ( $self, %opt ) = @_; + + my @years = $self->get_nav_years(%opt); + + for my $year (@years) { + my $stats = $self->stats_cache->get( + uid => $opt{uid}, + year => $year, + month => 0, + ); + $year->[2] = $stats // {}; + } + return @years; +} + +sub get_months_for_year { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my $year = $opt{year}; + + my $res = $db->select( + 'journeys', +'distinct extract(year from real_departure) as year, extract(month from real_departure) as month', + { user_id => $uid }, + { order_by => { -asc => 'year' } } + ); + + my @ret; + + for my $month ( 1 .. 12 ) { + push( @ret, + [ sprintf( '%d/%02d', $year, $month ), $month_name[ $month - 1 ] ] + ); + } + + for my $row ( $res->hashes->each ) { + if ( $row->{year} == $year ) { + + my $stats = $self->stats_cache->get( + db => $db, + uid => $uid, + year => $year, + month => $row->{month} + ); + + # undef -> no journeys for this month; empty hash -> no cached stats + $ret[ $row->{month} - 1 ][2] = $stats // {}; + } + } + return @ret; +} + +sub get_yyyymm_having_journeys { + my ( $self, %opt ) = @_; + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my $res = $db->select( + 'journeys', + "distinct to_char(real_departure, 'YYYY.MM') as yearmonth", + { user_id => $uid }, + { order_by => { -asc => 'yearmonth' } } + ); + + my @ret; + for my $row ( $res->hashes->each ) { + push( @ret, [ split( qr{[.]}, $row->{yearmonth} ) ] ); + } + + return @ret; +} + +sub generate_missing_stats { + my ( $self, %opt ) = @_; + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my @journey_months = $self->get_yyyymm_having_journeys( + uid => $uid, + db => $db + ); + my @stats_months = $self->stats_cache->get_yyyymm_having_stats( + uid => $uid, + $db => $db + ); + + my $stats_index = 0; + + for my $journey_index ( 0 .. $#journey_months ) { + if ( $stats_index < @stats_months + and $journey_months[$journey_index][0] + == $stats_months[$stats_index][0] + and $journey_months[$journey_index][1] + == $stats_months[$stats_index][1] ) + { + $stats_index++; + } + else { + my ( $year, $month ) = @{ $journey_months[$journey_index] }; + $self->get_stats( + uid => $uid, + db => $db, + year => $year, + month => $month, + write_only => 1 + ); + } + } +} + +sub get_nav_months { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my $filter_year = $opt{year}; + my $filter_month = $opt{month}; + + my $selected_index = undef; + + my $res = $db->select( + 'journeys', + "distinct to_char(real_departure, 'YYYY.MM') as yearmonth", + { user_id => $uid }, + { order_by => { -asc => 'yearmonth' } } + ); + + my @months; + for my $row ( $res->hashes->each ) { + my ( $year, $month ) = split( qr{[.]}, $row->{yearmonth} ); + push( @months, [ $year, $month ] ); + if ( $year eq $filter_year and $month eq $filter_month ) { + $selected_index = $#months; + } + } + + # returns (previous entry, current month, next entry). if there is no + # previous or next entry, the corresponding field is undef. Previous/next + # entry is usually previous/next month, but may also have a distance of + # more than one month if there are months without travels + my @ret = ( undef, undef, undef ); + + $ret[1] = [ + "${filter_year}/${filter_month}", + $month_name[ $filter_month - 1 ] // $filter_month + ]; + + if ( not defined $selected_index ) { + return @ret; + } + + if ( $selected_index > 0 and $months[ $selected_index - 1 ] ) { + my ( $year, $month ) = @{ $months[ $selected_index - 1 ] }; + $ret[0] = [ "${year}/${month}", "${month}.${year}" ]; + } + if ( $selected_index < $#months ) { + my ( $year, $month ) = @{ $months[ $selected_index + 1 ] }; + $ret[2] = [ "${year}/${month}", "${month}.${year}" ]; + } + + return @ret; +} + +sub sanity_check { + my ( $self, $journey, $lax ) = @_; + + if ( defined $journey->{sched_duration} + and $journey->{sched_duration} <= 0 ) + { + return +'Die geplante Dauer dieser Fahrt ist ≤ 0. Teleportation und Zeitreisen werden aktuell nicht unterstützt.'; + } + if ( defined $journey->{rt_duration} + and $journey->{rt_duration} <= 0 ) + { + return +'Die Dauer dieser Fahrt ist ≤ 0. Teleportation und Zeitreisen werden aktuell nicht unterstützt.'; + } + if ( $journey->{sched_duration} + and $journey->{sched_duration} > 60 * 60 * 24 ) + { + return 'Die Fahrt ist länger als 24 Stunden.'; + } + if ( $journey->{rt_duration} + and $journey->{rt_duration} > 60 * 60 * 24 ) + { + return 'Die Fahrt ist länger als 24 Stunden.'; + } + if ( $journey->{kmh_route} > 500 or $journey->{kmh_beeline} > 500 ) { + return 'Fahrten mit über 500 km/h? Schön wär\'s.'; + } + if ( $journey->{route} and @{ $journey->{route} } > 199 ) { + my $stop_count = @{ $journey->{route} }; + return +"Die Fahrt hat $stop_count Unterwegshalte. Also ich weiß ja nicht so recht."; + } + if ( $journey->{edited} & 0x0010 and not $lax ) { + my @unknown_stations + = $self->{stations} + ->grep_unknown( map { $_->[0] } @{ $journey->{route} } ); + if (@unknown_stations) { + return 'Unbekannte Station(en): ' . join( ', ', @unknown_stations ); + } + } + + return undef; +} + +sub get_travel_distance { + my ( $self, $journey ) = @_; + + my $from = $journey->{from_name}; + my $from_eva = $journey->{from_eva}; + my $from_latlon = $journey->{from_latlon}; + my $to = $journey->{to_name}; + my $to_eva = $journey->{to_eva}; + my $to_latlon = $journey->{to_latlon}; + my $route_ref = $journey->{route}; + my $polyline_ref = $journey->{polyline}; + + if ( not $to ) { + $self->{log} + ->warn("Journey $journey->{id} has no to_name for EVA $to_eva"); + } + + if ( not $from ) { + $self->{log} + ->warn("Journey $journey->{id} has no from_name for EVA $from_eva"); + } + + my $distance_polyline = 0; + my $distance_intermediate = 0; + my $distance_beeline = 0; + my $skipped = 0; + my $geo = GIS::Distance->new(); + my @stations = map { $_->[0] } @{$route_ref}; + my @route = after_incl { $_ eq $from } @stations; + @route = before_incl { $_ eq $to } @route; + + if ( @route < 2 ) { + + # I AM ERROR + return ( 0, 0, 0 ); + } + + my @polyline = after_incl { $_->[2] and $_->[2] == $from_eva } + @{ $polyline_ref // [] }; + @polyline + = before_incl { $_->[2] and $_->[2] == $to_eva } @polyline; + + my $prev_station = shift @polyline; + for my $station (@polyline) { + $distance_polyline += $geo->distance_metal( + $prev_station->[1], $prev_station->[0], + $station->[1], $station->[0] + ); + $prev_station = $station; + } + + $prev_station = $self->{latlon_by_station}->{ shift @route }; + if ( not $prev_station ) { + return ( $distance_polyline, 0, 0 ); + } + + for my $station_name (@route) { + if ( my $station = $self->{latlon_by_station}->{$station_name} ) { + $distance_intermediate += $geo->distance_metal( + $prev_station->[0], $prev_station->[1], + $station->[0], $station->[1] + ); + $prev_station = $station; + } + } + + $distance_beeline = $geo->distance_metal( @{$from_latlon}, @{$to_latlon} ); + + return ( $distance_polyline, $distance_intermediate, + $distance_beeline, $skipped ); +} + +sub grep_single { + my ( $self, @journeys ) = @_; + + my %num_by_trip; + for my $journey (@journeys) { + if ( $journey->{from_name} and $journey->{to_name} ) { + $num_by_trip{ $journey->{from_name} . '|' . $journey->{to_name} } + += 1; + } + } + + return + grep { $num_by_trip{ $_->{from_name} . '|' . $_->{to_name} } == 1 } + @journeys; +} + +sub compute_review { + my ( $self, $stats, @journeys ) = @_; + my $longest_km; + my $longest_t; + my $shortest_km; + my $shortest_t; + my $most_delayed; + my $most_delay; + my $most_undelay; + my $num_cancelled = 0; + my $num_fgr = 0; + my $num_punctual = 0; + my $message_count = 0; + my %num_by_message; + my %num_by_wrtype; + my %num_by_linetype; + my %num_by_stop; + my %num_by_trip; + + if ( not $stats or not @journeys or $stats->{num_trains} == 0 ) { + return; + } + + my %review; + + for my $journey (@journeys) { + if ( $journey->{cancelled} ) { + $num_cancelled += 1; + next; + } + + my %seen; + + if ( $journey->{rt_duration} and $journey->{rt_duration} > 0 ) { + if ( not $longest_t + or $journey->{rt_duration} > $longest_t->{rt_duration} ) + { + $longest_t = $journey; + } + if ( not $shortest_t + or $journey->{rt_duration} < $shortest_t->{rt_duration} ) + { + $shortest_t = $journey; + } + } + + if ( $journey->{km_route} ) { + if ( not $longest_km + or $journey->{km_route} > $longest_km->{km_route} ) + { + $longest_km = $journey; + } + if ( not $shortest_km + or $journey->{km_route} < $shortest_km->{km_route} ) + { + $shortest_km = $journey; + } + } + + if ( $journey->{messages} and @{ $journey->{messages} } ) { + $message_count += 1; + for my $message ( @{ $journey->{messages} } ) { + if ( not $seen{ $message->[1] } ) { + $num_by_message{ $message->[1] } += 1; + $seen{ $message->[1] } = 1; + } + } + } + + if ( $journey->{type} ) { + $num_by_linetype{ $journey->{type} } += 1; + } + + if ( $journey->{from_name} ) { + $num_by_stop{ $journey->{from_name} } += 1; + } + if ( $journey->{to_name} ) { + $num_by_stop{ $journey->{to_name} } += 1; + } + if ( $journey->{from_name} and $journey->{to_name} ) { + $num_by_trip{ $journey->{from_name} . '|' . $journey->{to_name} } + += 1; + } + + if ( $journey->{sched_dep_ts} and $journey->{rt_dep_ts} ) { + $journey->{delay_dep} + = ( $journey->{rt_dep_ts} - $journey->{sched_dep_ts} ) / 60; + } + if ( $journey->{sched_arr_ts} and $journey->{rt_arr_ts} ) { + $journey->{delay_arr} + = ( $journey->{rt_arr_ts} - $journey->{sched_arr_ts} ) / 60; + } + + if ( $journey->{delay_arr} and $journey->{delay_arr} >= 60 ) { + $num_fgr += 1; + } + if ( not $journey->{delay_arr} and not $journey->{delay_dep} ) { + $num_punctual += 1; + } + + if ( $journey->{delay_arr} and $journey->{delay_arr} > 0 ) { + if ( not $most_delayed + or $journey->{delay_arr} > $most_delayed->{delay_arr} ) + { + $most_delayed = $journey; + } + } + + if ( $journey->{rt_duration} + and $journey->{sched_duration} + and $journey->{rt_duration} > 0 + and $journey->{sched_duration} > 0 ) + { + my $slowdown = $journey->{rt_duration} - $journey->{sched_duration}; + my $speedup = -$slowdown; + if ( + not $most_delay + or $slowdown > ( + $most_delay->{rt_duration} - $most_delay->{sched_duration} + ) + ) + { + $most_delay = $journey; + } + if ( + not $most_undelay + or $speedup > ( + $most_undelay->{sched_duration} + - $most_undelay->{rt_duration} + ) + ) + { + $most_undelay = $journey; + } + } + } + + my @linetypes = sort { $b->[1] <=> $a->[1] } + map { [ $_, $num_by_linetype{$_} ] } keys %num_by_linetype; + my @stops = sort { $b->[1] <=> $a->[1] } + map { [ $_, $num_by_stop{$_} ] } keys %num_by_stop; + my @trips = sort { $b->[1] <=> $a->[1] } + map { [ $_, $num_by_trip{$_} ] } keys %num_by_trip; + + my @reasons = sort { $b->[1] <=> $a->[1] } + map { [ $_, $num_by_message{$_} ] } keys %num_by_message; + + $review{num_stops} = scalar @stops; + $review{km_circle} = $stats->{km_route} / 40030; + $review{km_diag} = $stats->{km_route} / 12742; + + $review{trains_per_day} = sprintf( '%.1f', $stats->{num_trains} / 365 ); + $review{km_route} = sprintf( '%.0f', $stats->{km_route} ); + $review{km_beeline} = sprintf( '%.0f', $stats->{km_beeline} ); + $review{km_circle_h} = sprintf( '%.1f', $review{km_circle} ); + $review{km_diag_h} = sprintf( '%.1f', $review{km_diag} ); + + $review{trains_per_day} =~ tr{.}{,}; + $review{km_circle_h} =~ tr{.}{,}; + $review{km_diag_h} =~ tr{.}{,}; + + my $min_total = $stats->{min_travel_real} + $stats->{min_interchange_real}; + $review{traveling_min_total} = $min_total; + $review{traveling_percentage_year} + = sprintf( "%.1f%%", $min_total * 100 / 525948.77 ); + $review{traveling_percentage_year} =~ tr{.}{,}; + $review{traveling_time_year} = $self->min_to_human($min_total); + + if (@linetypes) { + $review{typical_type_1} = $linetypes[0][0]; + } + if ( @linetypes > 1 ) { + $review{typical_type_2} = $linetypes[1][0]; + } + if ( @stops >= 3 ) { + my $desc = q{}; + $review{typical_stops_3} = [ $stops[0][0], $stops[1][0], $stops[2][0] ]; + } + elsif ( @stops == 2 ) { + $review{typical_stops_2} = [ $stops[0][0], $stops[1][0] ]; + } + $review{typical_time} + = $self->min_to_human( $stats->{min_travel_real} / $stats->{num_trains} ); + $review{typical_km} + = sprintf( '%.0f', $stats->{km_route} / $stats->{num_trains} ); + $review{typical_kmh} = sprintf( '%.0f', + $stats->{km_route} / ( $stats->{min_travel_real} / 60 ) ); + $review{typical_delay_dep} + = sprintf( '%.0f', $stats->{delay_dep} / $stats->{num_trains} ); + $review{typical_delay_dep_h} + = $self->min_to_human( $review{typical_delay_dep} ); + $review{typical_delay_arr} + = sprintf( '%.0f', $stats->{delay_arr} / $stats->{num_trains} ); + $review{typical_delay_arr_h} + = $self->min_to_human( $review{typical_delay_arr} ); + + if ($longest_t) { + $review{longest_t_time} + = $self->min_to_human( $longest_t->{rt_duration} / 60 ); + $review{longest_t_type} = $longest_t->{type}; + $review{longest_t_lineno} = $longest_t->{line} // $longest_t->{no}; + $review{longest_t_from} = $longest_t->{from_name}; + $review{longest_t_to} = $longest_t->{to_name}; + $review{longest_t_id} = $longest_t->{id}; + } + + if ($longest_km) { + $review{longest_km_km} = sprintf( '%.0f', $longest_km->{km_route} ); + $review{longest_km_type} = $longest_km->{type}; + $review{longest_km_lineno} = $longest_km->{line} // $longest_km->{no}; + $review{longest_km_from} = $longest_km->{from_name}; + $review{longest_km_to} = $longest_km->{to_name}; + $review{longest_km_id} = $longest_km->{id}; + } + + if ($shortest_t) { + $review{shortest_t_time} + = $self->min_to_human( $shortest_t->{rt_duration} / 60 ); + $review{shortest_t_type} = $shortest_t->{type}; + $review{shortest_t_lineno} = $shortest_t->{line} // $shortest_t->{no}; + $review{shortest_t_from} = $shortest_t->{from_name}; + $review{shortest_t_to} = $shortest_t->{to_name}; + $review{shortest_t_id} = $shortest_t->{id}; + } + + if ($shortest_km) { + $review{shortest_km_m} + = sprintf( '%.0f', $shortest_km->{km_route} * 1000 ); + $review{shortest_km_type} = $shortest_km->{type}; + $review{shortest_km_lineno} = $shortest_km->{line} + // $shortest_km->{no}; + $review{shortest_km_from} = $shortest_km->{from_name}; + $review{shortest_km_to} = $shortest_km->{to_name}; + $review{shortest_km_id} = $shortest_km->{id}; + } + + if ($most_delayed) { + $review{most_delayed_type} = $most_delayed->{type}; + $review{most_delayed_delay_dep} + = $self->min_to_human( $most_delayed->{delay_dep} ); + $review{most_delayed_delay_arr} + = $self->min_to_human( $most_delayed->{delay_arr} ); + $review{most_delayed_lineno} = $most_delayed->{line} + // $most_delayed->{no}; + $review{most_delayed_from} = $most_delayed->{from_name}; + $review{most_delayed_to} = $most_delayed->{to_name}; + $review{most_delayed_id} = $most_delayed->{id}; + } + + if ($most_delay) { + $review{most_delay_type} = $most_delay->{type}; + $review{most_delay_delay_dep} = $most_delay->{delay_dep}; + $review{most_delay_delay_arr} = $most_delay->{delay_arr}; + $review{most_delay_sched_time} + = $self->min_to_human( $most_delay->{sched_duration} / 60 ); + $review{most_delay_real_time} + = $self->min_to_human( $most_delay->{rt_duration} / 60 ); + $review{most_delay_delta} + = $self->min_to_human( + ( $most_delay->{rt_duration} - $most_delay->{sched_duration} ) + / 60 ); + $review{most_delay_lineno} = $most_delay->{line} // $most_delay->{no}; + $review{most_delay_from} = $most_delay->{from_name}; + $review{most_delay_to} = $most_delay->{to_name}; + $review{most_delay_id} = $most_delay->{id}; + } + + if ($most_undelay) { + $review{most_undelay_type} = $most_undelay->{type}; + $review{most_undelay_delay_dep} = $most_undelay->{delay_dep}; + $review{most_undelay_delay_arr} = $most_undelay->{delay_arr}; + $review{most_undelay_sched_time} + = $self->min_to_human( $most_undelay->{sched_duration} / 60 ); + $review{most_undelay_real_time} + = $self->min_to_human( $most_undelay->{rt_duration} / 60 ); + $review{most_undelay_delta} + = $self->min_to_human( + ( $most_undelay->{sched_duration} - $most_undelay->{rt_duration} ) + / 60 ); + $review{most_undelay_lineno} = $most_undelay->{line} + // $most_undelay->{no}; + $review{most_undelay_from} = $most_undelay->{from_name}; + $review{most_undelay_to} = $most_undelay->{to_name}; + $review{most_undelay_id} = $most_undelay->{id}; + } + + $review{issue_percent} + = sprintf( '%.0f%%', $message_count * 100 / $stats->{num_trains} ); + for my $i ( 0 .. 2 ) { + if ( $reasons[$i] ) { + my $p = 'issue' . ( $i + 1 ); + $review{"${p}_count"} = $reasons[$i][1]; + $review{"${p}_text"} = $reasons[$i][0]; + } + } + + $review{cancel_count} = $num_cancelled; + $review{fgr_percent} = $num_fgr * 100 / $stats->{num_trains}; + $review{fgr_percent_h} = sprintf( '%.1f%%', $review{fgr_percent} ); + $review{fgr_percent_h} =~ tr{.}{,}; + $review{punctual_percent} = $num_punctual * 100 / $stats->{num_trains}; + $review{punctual_percent_h} + = sprintf( '%.1f%%', $review{punctual_percent} ); + $review{punctual_percent_h} =~ tr{.}{,}; + + my $top_trip_count = 0; + my $single_trip_count = 0; + for my $i ( 0 .. 3 ) { + if ( $trips[$i] ) { + my ( $from, $to ) = split( qr{[|]}, $trips[$i][0] ); + my $found = 0; + for my $j ( 0 .. $#{ $review{top_trips} } ) { + if ( $review{top_trips}[$j][0] eq $to + and $review{top_trips}[$j][2] eq $from ) + { + $review{top_trips}[$j][1] = '↔'; + $found = 1; + last; + } + } + if ( not $found ) { + push( @{ $review{top_trips} }, [ $from, '→', $to ] ); + } + $top_trip_count += $trips[$i][1]; + } + } + + for my $trip (@trips) { + if ( $trip->[1] == 1 ) { + $single_trip_count += 1; + if ( @{ $review{single_trips} // [] } < 3 ) { + push( + @{ $review{single_trips} }, + [ split( qr{[|]}, $trip->[0] ) ] + ); + } + } + } + + $review{top_trip_count} = $top_trip_count; + $review{top_trip_percent_h} + = sprintf( '%.1f%%', $top_trip_count * 100 / $stats->{num_trains} ); + $review{top_trip_percent_h} =~ tr{.}{,}; + + $review{single_trip_count} = $single_trip_count; + $review{single_trip_percent_h} + = sprintf( '%.1f%%', $single_trip_count * 100 / $stats->{num_trains} ); + $review{single_trip_percent_h} =~ tr{.}{,}; + + return \%review; +} + +sub compute_stats { + my ( $self, @journeys ) = @_; + my $km_route = 0; + my $km_beeline = 0; + my $min_travel_sched = 0; + my $min_travel_real = 0; + my $delay_dep = 0; + my $delay_arr = 0; + my $interchange_real = 0; + my $num_trains = 0; + my $num_journeys = 0; + my @inconsistencies; + + my $next_departure = 0; + my $next_id; + my $next_train; + + for my $journey (@journeys) { + $num_trains++; + $km_route += $journey->{km_route}; + $km_beeline += $journey->{km_beeline}; + if ( $journey->{sched_duration} + and $journey->{sched_duration} > 0 ) + { + $min_travel_sched += $journey->{sched_duration} / 60; + } + if ( $journey->{rt_duration} and $journey->{rt_duration} > 0 ) { + $min_travel_real += $journey->{rt_duration} / 60; + } + if ( $journey->{sched_dep_ts} and $journey->{rt_dep_ts} ) { + $delay_dep + += ( $journey->{rt_dep_ts} - $journey->{sched_dep_ts} ) / 60; + } + if ( $journey->{sched_arr_ts} and $journey->{rt_arr_ts} ) { + $delay_arr + += ( $journey->{rt_arr_ts} - $journey->{sched_arr_ts} ) / 60; + } + + # Note that journeys are sorted from recent to older entries + if ( $journey->{rt_arr_ts} + and $next_departure + and $next_departure - $journey->{rt_arr_ts} < ( 60 * 60 ) ) + { + if ( $next_departure - $journey->{rt_arr_ts} < 0 ) { + push( + @inconsistencies, + { + conflict => { + train => $journey->{type} . ' ' + . ( $journey->{line} // $journey->{no} ), + arr => epoch_to_dt( $journey->{rt_arr_ts} ) + ->strftime('%d.%m.%Y %H:%M'), + id => $journey->{id}, + }, + ignored => { + train => $next_train, + dep => epoch_to_dt($next_departure) + ->strftime('%d.%m.%Y %H:%M'), + id => $next_id, + }, + } + ); + } + else { + $interchange_real + += ( $next_departure - $journey->{rt_arr_ts} ) / 60; + } + } + else { + $num_journeys++; + } + $next_departure = $journey->{rt_dep_ts}; + $next_id = $journey->{id}; + $next_train + = $journey->{type} . ' ' . ( $journey->{line} // $journey->{no} ),; + } + my $ret = { + km_route => $km_route, + km_beeline => $km_beeline, + num_trains => $num_trains, + num_journeys => $num_journeys, + min_travel_sched => $min_travel_sched, + min_travel_real => $min_travel_real, + min_interchange_real => $interchange_real, + delay_dep => $delay_dep, + delay_arr => $delay_arr, + inconsistencies => \@inconsistencies, + }; + for my $key ( + qw(min_travel_sched min_travel_real min_interchange_real delay_dep delay_arr) + ) + { + my $strf_key = $key . '_strf'; + my $value = $ret->{$key}; + $ret->{$strf_key} = q{}; + if ( $ret->{$key} < 0 ) { + $ret->{$strf_key} .= '-'; + $value *= -1; + } + $ret->{$strf_key} .= sprintf( '%02d:%02d', $value / 60, $value % 60 ); + } + return $ret; +} + +sub get_stats { + my ( $self, %opt ) = @_; + + if ( $opt{cancelled} ) { + $self->{log} + ->warn('get_journey_stats called with illegal option cancelled => 1'); + return {}; + } + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + my $year = $opt{year} // 0; + my $month = $opt{month} // 0; + + # Assumption: If the stats cache contains an entry it is up-to-date. + # -> Cache entries must be explicitly invalidated whenever the user + # checks out of a train or manually edits/adds a journey. + + if ( + not $opt{write_only} + and not $opt{review} + and my $stats = $self->stats_cache->get( + uid => $uid, + db => $db, + year => $year, + month => $month + ) + ) + { + return $stats; + } + + my $interval_start = DateTime->new( + time_zone => 'Europe/Berlin', + year => 2000, + month => 1, + day => 1, + hour => 0, + minute => 0, + second => 0, + ); + + # I wonder if people will still be traveling by train in the year 3000 + my $interval_end = $interval_start->clone->add( years => 1000 ); + + if ( $opt{year} and $opt{month} ) { + $interval_start->set( + year => $opt{year}, + month => $opt{month} + ); + $interval_end = $interval_start->clone->add( months => 1 ); + } + elsif ( $opt{year} ) { + $interval_start->set( year => $opt{year} ); + $interval_end = $interval_start->clone->add( years => 1 ); + } + + my @journeys = $self->get( + uid => $uid, + cancelled => 0, + verbose => 1, + with_polyline => 1, + after => $interval_start, + before => $interval_end + ); + my $stats = $self->compute_stats(@journeys); + + $self->stats_cache->add( + uid => $uid, + db => $db, + year => $year, + month => $month, + stats => $stats + ); + + if ( $opt{review} ) { + my @cancelled_journeys = $self->get( + uid => $uid, + cancelled => 1, + verbose => 1, + after => $interval_start, + before => $interval_end + ); + return ( $stats, + $self->compute_review( $stats, @journeys, @cancelled_journeys ) ); + } + + return $stats; +} + +sub get_latest_dest_id { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + + if ( + my $id = $self->{in_transit}->get_checkout_station_id( + uid => $uid, + db => $db + ) + ) + { + return $id; + } + + return $self->get_latest_checkout_station_id( + uid => $uid, + db => $db + ); +} + +sub get_connection_targets { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $threshold = $opt{threshold} + // DateTime->now( time_zone => 'Europe/Berlin' )->subtract( months => 4 ); + my $db = $opt{db} //= $self->{pg}->db; + my $min_count = $opt{min_count} // 3; + + if ( $opt{destination_name} ) { + return ( + [], + [ { eva => $opt{eva}, name => $opt{destination_name} } ] + ); + } + + my $dest_id = $opt{eva} // $self->get_latest_dest_id(%opt); + + if ( not $dest_id ) { + return ( [], [] ); + } + + my $dest_ids = [ $dest_id, $self->{stations}->get_meta( eva => $dest_id ) ]; + + my $res = $db->select( + 'journeys', + 'count(checkout_station_id) as count, checkout_station_id as dest', + { + user_id => $uid, + checkin_station_id => $dest_ids, + real_departure => { '>', $threshold } + }, + { + group_by => ['checkout_station_id'], + order_by => { -desc => 'count' } + } + ); + my @destinations + = $res->hashes->grep( sub { shift->{count} >= $min_count } ) + ->map( sub { shift->{dest} } )->each; + @destinations = $self->{stations}->get_by_evas(@destinations); + return ( $dest_ids, \@destinations ); +} + +sub update_visibility { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + + my $visibility; + + if ( $opt{visibility} and $visibility_atoi{ $opt{visibility} } ) { + $visibility = $visibility_atoi{ $opt{visibility} }; + } + + $db->update( + 'journeys', + { visibility => $visibility }, + { + user_id => $uid, + id => $opt{id} + } + ); +} + +1; diff --git a/lib/Travelynx/Model/Stations.pm b/lib/Travelynx/Model/Stations.pm new file mode 100644 index 0000000..ac4019c --- /dev/null +++ b/lib/Travelynx/Model/Stations.pm @@ -0,0 +1,199 @@ +package Travelynx::Model::Stations; + +# Copyright (C) 2022 Birte Kristina Friesel +# +# SPDX-License-Identifier: AGPL-3.0-or-later + +use strict; +use warnings; +use 5.020; + +sub new { + my ( $class, %opt ) = @_; + + return bless( \%opt, $class ); +} + +sub add_or_update { + my ( $self, %opt ) = @_; + my $stop = $opt{stop}; + my $loc = $stop->loc; + my $source = 1; + my $db = $opt{db} // $self->{pg}->db; + + if ( my $s = $self->get_by_eva( $loc->eva, db => $db ) ) { + if ( $source == 1 and $s->{source} == 0 and not $s->{archived} ) { + return; + } + $db->update( + 'stations', + { + name => $loc->name, + lat => $loc->lat, + lon => $loc->lon, + source => $source, + archived => 0 + }, + { eva => $loc->eva } + ); + return; + } + $db->insert( + 'stations', + { + eva => $loc->eva, + name => $loc->name, + lat => $loc->lat, + lon => $loc->lon, + source => $source, + archived => 0 + } + ); +} + +sub add_meta { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $eva = $opt{eva}; + my @meta = @{ $opt{meta} }; + + for my $meta (@meta) { + if ( $meta != $eva ) { + $db->insert( + 'related_stations', + { + eva => $eva, + meta => $meta + }, + { on_conflict => undef } + ); + } + } +} + +sub get_db_iterator { + my ($self) = @_; + + return $self->{pg}->db->select( 'stations', '*' ); +} + +sub get_meta { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $eva = $opt{eva}; + + my $res = $db->select( 'related_stations', ['meta'], { eva => $eva } ); + my @ret; + + while ( my $row = $res->hash ) { + push( @ret, $row->{meta} ); + } + + return @ret; +} + +sub get_for_autocomplete { + my ($self) = @_; + + my $res = $self->{pg}->db->select( 'stations', ['name'] ); + my %ret; + + while ( my $row = $res->hash ) { + $ret{ $row->{name} } = undef; + } + + return \%ret; +} + +# Fast +sub get_by_eva { + my ( $self, $eva, %opt ) = @_; + + if ( not $eva ) { + return; + } + + my $db = $opt{db} // $self->{pg}->db; + + return $db->select( 'stations', '*', { eva => $eva } )->hash; +} + +# Fast +sub get_by_evas { + my ( $self, @evas ) = @_; + + my @ret + = $self->{pg}->db->select( 'stations', '*', { eva => { '=', \@evas } } ) + ->hashes->each; + return @ret; +} + +# Slow +sub get_latlon_by_name { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + + my %location; + my $res = $db->select( 'stations', [ 'name', 'lat', 'lon' ] ); + while ( my $row = $res->hash ) { + $location{ $row->{name} } = [ $row->{lat}, $row->{lon} ]; + } + return \%location; +} + +# Slow +sub get_by_name { + my ( $self, $name, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + + return $db->select( 'stations', '*', { name => $name }, { limit => 1 } ) + ->hash; +} + +# Slow +sub get_by_names { + my ( $self, @names ) = @_; + + my @ret + = $self->{pg}->db->select( 'stations', '*', { name => { '=', \@names } } ) + ->hashes->each; + return @ret; +} + +# Slow +sub get_by_ds100 { + my ( $self, $ds100, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + + return $db->select( 'stations', '*', { ds100 => $ds100 }, { limit => 1 } ) + ->hash; +} + +# Can be slow +sub search { + my ( $self, $identifier, %opt ) = @_; + + if ( $identifier =~ m{ ^ \d+ $ }x ) { + return $self->get_by_eva( $identifier, %opt ) + // $self->get_by_ds100( $identifier, %opt ) + // $self->get_by_name( $identifier, %opt ); + } + + return $self->get_by_ds100( $identifier, %opt ) + // $self->get_by_name( $identifier, %opt ); +} + +# Slow +sub grep_unknown { + my ( $self, @stations ) = @_; + + my %station = map { $_->{name} => 1 } $self->get_by_names(@stations); + my @unknown_stations = grep { not $station{$_} } @stations; + + return @unknown_stations; +} + +1; diff --git a/lib/Travelynx/Model/Traewelling.pm b/lib/Travelynx/Model/Traewelling.pm new file mode 100644 index 0000000..25648cc --- /dev/null +++ b/lib/Travelynx/Model/Traewelling.pm @@ -0,0 +1,243 @@ +package Travelynx::Model::Traewelling; + +# Copyright (C) 2020-2023 Birte Kristina Friesel +# +# SPDX-License-Identifier: AGPL-3.0-or-later + +use strict; +use warnings; +use 5.020; + +use DateTime; + +sub epoch_to_dt { + my ($epoch) = @_; + + # Bugs (and user errors) may lead to undefined timestamps. Set them to + # 1970-01-01 to avoid crashing and show obviously wrong data instead. + $epoch //= 0; + + return DateTime->from_epoch( + epoch => $epoch, + time_zone => 'Europe/Berlin', + locale => 'de-DE', + ); + +} + +sub new { + my ( $class, %opt ) = @_; + + return bless( \%opt, $class ); +} + +sub now { + return DateTime->now( time_zone => 'Europe/Berlin' ); +} + +sub link { + my ( $self, %opt ) = @_; + + my $log = [ [ $self->now->epoch, "Erfolgreich mittels OAuth2 verbunden" ] ]; + + my $data = { log => $log }; + + my $user_entry = { + user_id => $opt{uid}, + push_sync => 0, + pull_sync => 0, + token => $opt{token}, + refresh_token => $opt{refresh_token}, + expiry => epoch_to_dt( $self->now->epoch + $opt{expires_in} ), + data => JSON->new->encode($data), + }; + + $self->{pg}->db->insert( + 'traewelling', + $user_entry, + { + on_conflict => \ +'(user_id) do update set token = EXCLUDED.token, refresh_token = EXCLUDED.refresh_token, expiry = EXCLUDED.expiry, push_sync = false, pull_sync = false, data = null, errored = false, latest_run = null' + } + ); + + return $user_entry; +} + +sub set_user { + my ( $self, %opt ) = @_; + + my $res_h + = $self->{pg} + ->db->select( 'traewelling', 'data', { user_id => $opt{uid} } ) + ->expand->hash; + + $res_h->{data}{user_id} = $opt{trwl_id}; + $res_h->{data}{screen_name} = $opt{screen_name}; + $res_h->{data}{user_name} = $opt{user_name}; + + $self->{pg}->db->update( + 'traewelling', + { data => JSON->new->encode( $res_h->{data} ) }, + { user_id => $opt{uid} } + ); +} + +sub unlink { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + + $self->{pg}->db->delete( 'traewelling', { user_id => $uid } ); +} + +sub get { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + + my $res_h + = $db->select( 'traewelling_str', '*', { user_id => $uid } ) + ->expand->hash; + + $res_h->{latest_run} = epoch_to_dt( $res_h->{latest_run_ts} ); + for my $log_entry ( @{ $res_h->{data}{log} // [] } ) { + $log_entry->[0] = epoch_to_dt( $log_entry->[0] ); + } + $res_h->{expires_on} + = epoch_to_dt( $res_h->{expiry_ts} // $res_h->{data}{expires} ); + + my $expires_in = ( $res_h->{expiry_ts} // $res_h->{data}{expires} // 0 ) + - $self->now->epoch; + + if ( $expires_in < 0 ) { + $res_h->{expired} = 1; + } + elsif ( $expires_in < 14 * 24 * 3600 ) { + $res_h->{expiring} = 1; + } + + return $res_h; +} + +sub log { + my ( $self, %opt ) = @_; + my $uid = $opt{uid}; + my $message = $opt{message}; + my $is_error = $opt{is_error}; + my $db = $opt{db} // $self->{pg}->db; + my $res_h + = $db->select( 'traewelling', 'data', { user_id => $uid } )->expand->hash; + splice( @{ $res_h->{data}{log} // [] }, 9 ); + unshift( + @{ $res_h->{data}{log} }, + [ $self->now->epoch, $message, $opt{status_id} ] + ); + + if ($is_error) { + $res_h->{data}{error} = $message; + } + $db->update( + 'traewelling', + { + errored => $is_error ? 1 : 0, + latest_run => $self->now, + data => JSON->new->encode( $res_h->{data} ) + }, + { user_id => $uid } + ); +} + +sub set_latest_pull_status_id { + my ( $self, %opt ) = @_; + my $uid = $opt{uid}; + my $status_id = $opt{status_id}; + my $db = $opt{db} // $self->{pg}->db; + + my $res_h + = $db->select( 'traewelling', 'data', { user_id => $uid } )->expand->hash; + + $res_h->{data}{latest_pull_status_id} = $status_id; + + $db->update( + 'traewelling', + { data => JSON->new->encode( $res_h->{data} ) }, + { user_id => $uid } + ); +} + +sub set_latest_push_ts { + my ( $self, %opt ) = @_; + my $uid = $opt{uid}; + my $ts = $opt{ts}; + my $db = $opt{db} // $self->{pg}->db; + + my $res_h + = $db->select( 'traewelling', 'data', { user_id => $uid } )->expand->hash; + + $res_h->{data}{latest_push_ts} = $ts; + + $db->update( + 'traewelling', + { data => JSON->new->encode( $res_h->{data} ) }, + { user_id => $uid } + ); +} + +sub set_sync { + my ( $self, %opt ) = @_; + + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + + my $res_h + = $db->select( 'traewelling', 'data', { user_id => $uid } )->expand->hash; + + $res_h->{data}{toot} = $opt{toot}; + $res_h->{data}{tweet} = $opt{tweet}; + + $db->update( + 'traewelling', + { + push_sync => $opt{push_sync}, + pull_sync => $opt{pull_sync}, + data => JSON->new->encode( $res_h->{data} ), + }, + { user_id => $uid } + ); +} + +sub get_pushable_accounts { + my ($self) = @_; + my $res = $self->{pg}->db->query( + qq{select t.user_id as uid, t.token as token, t.data as data, + i.user_data as user_data, + i.dep_eva as dep_eva, i.arr_eva as arr_eva, + i.data as journey_data, i.train_type as train_type, + i.train_line as train_line, i.train_no as train_no, + i.checkin_ts as checkin_ts, + i.sched_dep_ts as dep_ts, + i.sched_arr_ts as arr_ts, + i.effective_visibility as visibility + from traewelling as t + join in_transit_str as i on t.user_id = i.user_id + where t.push_sync = True + and i.arr_eva is not null + and i.cancelled = False + } + ); + return $res->expand->hashes->each; +} + +sub get_pull_accounts { + my ($self) = @_; + my $res = $self->{pg}->db->select( + 'traewelling', + [ 'user_id', 'token', 'data' ], + { pull_sync => 1 } + ); + return $res->expand->hashes->each; +} + +1; diff --git a/lib/Travelynx/Model/Users.pm b/lib/Travelynx/Model/Users.pm new file mode 100644 index 0000000..4602fa2 --- /dev/null +++ b/lib/Travelynx/Model/Users.pm @@ -0,0 +1,1160 @@ +package Travelynx::Model::Users; + +# Copyright (C) 2020-2023 Birte Kristina Friesel +# +# SPDX-License-Identifier: AGPL-3.0-or-later + +use strict; +use warnings; +use 5.020; + +use Crypt::Eksblowfish::Bcrypt qw(bcrypt en_base64); +use DateTime; +use JSON; + +my %visibility_itoa = ( + 100 => 'public', + 80 => 'travelynx', + 60 => 'followers', + 30 => 'unlisted', + 10 => 'private', +); + +my %visibility_atoi = ( + public => 100, + travelynx => 80, + followers => 60, + unlisted => 30, + private => 10, +); + +my %predicate_itoa = ( + 1 => 'follows', + 2 => 'requests_follow', + 3 => 'is_blocked_by', +); + +my %predicate_atoi = ( + follows => 1, + requests_follow => 2, + is_blocked_by => 3, +); + +my @sb_templates = ( + undef, + [ 'DBF', 'https://dbf.finalrewind.org/{name}?rt=1#{tt}{tn}' ], + [ 'bahn.expert', 'https://bahn.expert/{name}#{id}' ], + [ 'DBF HAFAS', 'https://dbf.finalrewind.org/{name}?rt=1&hafas=1#{tt}{tn}' ], + [ 'bahn.expert/regional', 'https://bahn.expert/regional/{name}#{id}' ], +); + +my %token_id = ( + status => 1, + history => 2, + travel => 3, + import => 4, +); +my @token_types = (qw(status history travel import)); + +sub new { + my ( $class, %opt ) = @_; + + return bless( \%opt, $class ); +} + +sub hash_password { + my ( $self, $password ) = @_; + my @salt_bytes = map { int( rand(255) ) + 1 } ( 1 .. 16 ); + my $salt = en_base64( pack( 'C[16]', @salt_bytes ) ); + + return bcrypt( substr( $password, 0, 10000 ), '$2a$12$' . $salt ); +} + +sub get_token_id { + my ( $self, $type ) = @_; + + return $token_id{$type}; +} + +sub mark_seen { + my ( $self, %opt ) = @_; + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + + $db->update( + 'users', + { + last_seen => DateTime->now( time_zone => 'Europe/Berlin' ), + deletion_notified => undef + }, + { id => $uid } + ); +} + +sub mark_deletion_notified { + my ( $self, %opt ) = @_; + my $uid = $opt{uid}; + my $db = $opt{db} // $self->{pg}->db; + + $db->update( + 'users', + { + deletion_notified => DateTime->now( time_zone => 'Europe/Berlin' ), + }, + { id => $uid } + ); +} + +sub verify_registration_token { + my ( $self, %opt ) = @_; + my $uid = $opt{uid}; + my $token = $opt{token}; + my $db = $opt{db} // $self->{pg}->db; + + my $tx; + if ( not $opt{in_transaction} ) { + $tx = $db->begin; + } + + my $res = $db->select( + 'pending_registrations', + 'count(*) as count', + { + user_id => $uid, + token => $token + } + ); + + if ( $res->hash->{count} ) { + $db->update( 'users', { status => 1 }, { id => $uid } ); + $db->delete( 'pending_registrations', { user_id => $uid } ); + if ($tx) { + $tx->commit; + } + return 1; + } + return; +} + +sub get_api_token { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + + my $token = {}; + my $res = $db->select( 'tokens', [ 'type', 'token' ], { user_id => $uid } ); + + for my $entry ( $res->hashes->each ) { + $token->{ $token_types[ $entry->{type} - 1 ] } + = $entry->{token}; + } + + return $token; +} + +sub get_uid_by_name_and_mail { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $name = $opt{name}; + my $email = $opt{email}; + + my $res = $db->select( + 'users', + ['id'], + { + name => $name, + email => $email, + status => 1 + } + ); + + if ( my $user = $res->hash ) { + return $user->{id}; + } + return; +} + +sub get_privacy_by { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + + my %where; + + if ( $opt{name} ) { + $where{name} = $opt{name}; + } + else { + $where{id} = $opt{uid}; + } + + my $res = $db->select( + 'users', + [ 'id', 'name', 'public_level', 'accept_follows' ], + { %where, status => 1 } + ); + + if ( my $user = $res->hash ) { + return { + id => $user->{id}, + name => $user->{name}, + default_visibility => $user->{public_level} & 0x7f, + default_visibility_str => + $visibility_itoa{ $user->{public_level} & 0x7f }, + comments_visible => $user->{public_level} & 0x80 ? 1 : 0, + past_visibility => ( $user->{public_level} & 0x7f00 ) >> 8, + past_visibility_str => + $visibility_itoa{ ( $user->{public_level} & 0x7f00 ) >> 8 }, + past_status => $user->{public_level} & 0x08000 ? 1 : 0, + past_all => $user->{public_level} & 0x10000 ? 1 : 0, + accept_follows => $user->{accept_follows} == 2 ? 1 : 0, + accept_follow_requests => $user->{accept_follows} == 1 ? 1 : 0, + }; + } + return; +} + +sub set_privacy { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + my $public_level = $opt{level}; + + if ( not defined $public_level and defined $opt{default_visibility} ) { + $public_level + = ( $opt{default_visibility} & 0x7f ) + | ( $opt{comments_visible} ? 0x80 : 0 ) + | ( ( $opt{past_visibility} & 0x7f ) << 8 ) + | ( $opt{past_status} ? 0x08000 : 0 ) + | ( $opt{past_all} ? 0x10000 : 0 ); + } + + $db->update( 'users', { public_level => $public_level }, { id => $uid } ); +} + +sub set_social { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + + my $accept_follows = 0; + + if ( $opt{accept_follows} ) { + $accept_follows = 2; + } + elsif ( $opt{accept_follow_requests} ) { + $accept_follows = 1; + } + + $db->update( + 'users', + { accept_follows => $accept_follows }, + { id => $uid } + ); +} + +sub mark_for_password_reset { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + my $token = $opt{token}; + + my $res = $db->select( + 'pending_passwords', + 'count(*) as count', + { user_id => $uid } + ); + if ( $res->hash->{count} ) { + return 'in progress'; + } + + $db->insert( + 'pending_passwords', + { + user_id => $uid, + token => $token, + requested_at => DateTime->now( time_zone => 'Europe/Berlin' ) + } + ); + + return undef; +} + +sub verify_password_token { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + my $token = $opt{token}; + + my $res = $db->select( + 'pending_passwords', + 'count(*) as count', + { + user_id => $uid, + token => $token + } + ); + + if ( $res->hash->{count} ) { + return 1; + } + return; +} + +sub mark_for_mail_change { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + my $email = $opt{email}; + my $token = $opt{token}; + + $db->insert( + 'pending_mails', + { + user_id => $uid, + email => $email, + token => $token, + requested_at => DateTime->now( time_zone => 'Europe/Berlin' ) + }, + { + on_conflict => \ +'(user_id) do update set email = EXCLUDED.email, token = EXCLUDED.token, requested_at = EXCLUDED.requested_at' + }, + ); +} + +sub change_mail_with_token { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + my $token = $opt{token}; + + my $tx = $db->begin; + + my $res_h = $db->select( + 'pending_mails', + ['email'], + { + user_id => $uid, + token => $token + } + )->hash; + + if ($res_h) { + $db->update( 'users', { email => $res_h->{email} }, { id => $uid } ); + $db->delete( 'pending_mails', { user_id => $uid } ); + $tx->commit; + return 1; + } + return; +} + +sub is_name_invalid { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $name = $opt{name}; + + if ( not length($name) ) { + return 'user_empty'; + } + + if ( $name !~ m{ ^ [0-9a-zA-Z_-]+ $ }x ) { + return 'user_format'; + } + + if ( + $self->user_name_exists( + db => $db, + name => $name + ) + ) + { + return 'user_collision'; + } + + return; +} + +sub change_name { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + + eval { $db->update( 'users', { name => $opt{name} }, { id => $uid } ); }; + + if ($@) { + return 0; + } + + return 1; +} + +sub remove_password_token { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + my $token = $opt{token}; + + $db->delete( + 'pending_passwords', + { + user_id => $uid, + token => $token + } + ); +} + +sub get { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + + my $user = $db->select( + 'users', + 'id, name, status, public_level, email, ' + . 'external_services, accept_follows, notifications, ' + . 'extract(epoch from registered_at) as registered_at_ts, ' + . 'extract(epoch from last_seen) as last_seen_ts, ' + . 'extract(epoch from deletion_requested) as deletion_requested_ts', + { id => $uid } + )->hash; + if ($user) { + return { + id => $user->{id}, + name => $user->{name}, + status => $user->{status}, + notifications => $user->{notifications}, + accept_follows => $user->{accept_follows} == 2 ? 1 : 0, + accept_follow_requests => $user->{accept_follows} == 1 ? 1 : 0, + default_visibility => $user->{public_level} & 0x7f, + default_visibility_str => + $visibility_itoa{ $user->{public_level} & 0x7f }, + comments_visible => $user->{public_level} & 0x80 ? 1 : 0, + past_visibility => ( $user->{public_level} & 0x7f00 ) >> 8, + past_visibility_str => + $visibility_itoa{ ( $user->{public_level} & 0x7f00 ) >> 8 }, + past_status => $user->{public_level} & 0x08000 ? 1 : 0, + past_all => $user->{public_level} & 0x10000 ? 1 : 0, + email => $user->{email}, + sb_name => $user->{external_services} + ? $sb_templates[ $user->{external_services} & 0x07 ][0] + : undef, + sb_template => $user->{external_services} + ? $sb_templates[ $user->{external_services} & 0x07 ][1] + : undef, + registered_at => DateTime->from_epoch( + epoch => $user->{registered_at_ts}, + time_zone => 'Europe/Berlin' + ), + last_seen => DateTime->from_epoch( + epoch => $user->{last_seen_ts}, + time_zone => 'Europe/Berlin' + ), + deletion_requested => $user->{deletion_requested_ts} + ? DateTime->from_epoch( + epoch => $user->{deletion_requested_ts}, + time_zone => 'Europe/Berlin' + ) + : undef, + }; + } + return undef; +} + +sub get_login_data { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $name = $opt{name}; + + my $res_h = $db->select( + 'users', + 'id, name, status, password as password_hash', + { name => $name } + )->hash; + + return $res_h; +} + +sub add { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $user_name = $opt{name}; + my $email = $opt{email}; + my $token = $opt{token}; + my $password = $self->hash_password( $opt{password} ); + + # This helper must be called during a transaction, as user creation + # may fail even after the database entry has been generated, e.g. if + # the registration mail cannot be sent. We therefore use $db (the + # database handle performing the transaction) instead of $self->pg->db + # (which may be a new handle not belonging to the transaction). + + my $now = DateTime->now( time_zone => 'Europe/Berlin' ); + + my $res = $db->insert( + 'users', + { + name => $user_name, + status => 0, + public_level => $visibility_atoi{unlisted} + | ( $visibility_atoi{unlisted} << 8 ), + email => $email, + password => $password, + registered_at => $now, + last_seen => $now, + }, + { returning => 'id' } + ); + my $uid = $res->hash->{id}; + + $db->insert( + 'pending_registrations', + { + user_id => $uid, + token => $token + } + ); + + return $uid; +} + +sub flag_deletion { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + + my $now = DateTime->now( time_zone => 'Europe/Berlin' ); + + $db->update( + 'users', + { deletion_requested => $now }, + { + id => $uid, + } + ); +} + +sub unflag_deletion { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + + $db->update( + 'users', + { + deletion_requested => undef, + }, + { + id => $uid, + } + ); +} + +sub delete { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + my $tx; + if ( not $opt{in_transaction} ) { + $tx = $db->begin; + } + + my %res; + + $res{tokens} = $db->delete( 'tokens', { user_id => $uid } ); + $res{stats} = $db->delete( 'journey_stats', { user_id => $uid } ); + $res{journeys} = $db->delete( 'journeys', { user_id => $uid } ); + $res{transit} = $db->delete( 'in_transit', { user_id => $uid } ); + $res{hooks} = $db->delete( 'webhooks', { user_id => $uid } ); + $res{trwl} = $db->delete( 'traewelling', { user_id => $uid } ); + $res{password} = $db->delete( 'pending_passwords', { user_id => $uid } ); + $res{relations} = $db->delete( 'relations', + [ { subject_id => $uid }, { object_id => $uid } ] ); + $res{users} = $db->delete( 'users', { id => $uid } ); + + for my $key ( keys %res ) { + $res{$key} = $res{$key}->rows; + } + + if ( $res{users} != 1 ) { + die("Deleted $res{users} rows from users, expected 1. Rolling back.\n"); + } + + if ($tx) { + $tx->commit; + } + + return \%res; +} + +sub set_password { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + my $password = $self->hash_password( $opt{password} ); + + $db->update( 'users', { password => $password }, { id => $uid } ); +} + +sub user_name_exists { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $user_name = $opt{name}; + + my $count + = $db->select( 'users', 'count(*) as count', { name => $user_name } ) + ->hash->{count}; + + if ($count) { + return 1; + } + return 0; +} + +sub mail_is_blacklisted { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $mail = $opt{email}; + + my $count = $db->select( + 'users', + 'count(*) as count', + { + email => $mail, + status => 0, + } + )->hash->{count}; + + if ($count) { + return 1; + } + + $count = $db->select( + 'mail_blacklist', + 'count(*) as count', + { + email => $mail, + num_tries => { '>', 1 }, + } + )->hash->{count}; + + if ($count) { + return 1; + } + return 0; +} + +sub use_history { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + my $value = $opt{set}; + + if ($value) { + $db->update( 'users', { use_history => $value }, { id => $uid } ); + } + else { + return $db->select( 'users', ['use_history'], { id => $uid } ) + ->hash->{use_history}; + } +} + +sub use_external_services { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + my $value = $opt{set}; + + if ( defined $value ) { + if ( $value < 0 or $value > 4 ) { + $value = 0; + } + $db->update( 'users', { external_services => $value }, { id => $uid } ); + } + else { + return $db->select( 'users', ['external_services'], { id => $uid } ) + ->hash->{external_services}; + } +} + +sub get_webhook { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + + my $res_h = $db->select( 'webhooks_str', '*', { user_id => $uid } )->hash; + + $res_h->{latest_run} = DateTime->from_epoch( + epoch => $res_h->{latest_run_ts} // 0, + time_zone => 'Europe/Berlin', + locale => 'de-DE', + ); + + return $res_h; +} + +sub set_webhook { + my ( $self, %opt ) = @_; + my $db = $opt{db} // $self->{pg}->db; + + if ( $opt{token} ) { + $opt{token} =~ tr{\r\n}{}d; + } + + my $res = $db->insert( + 'webhooks', + { + user_id => $opt{uid}, + enabled => $opt{enabled}, + url => $opt{url}, + token => $opt{token} + }, + { + on_conflict => \ +'(user_id) do update set enabled = EXCLUDED.enabled, url = EXCLUDED.url, token = EXCLUDED.token, errored = null, latest_run = null, output = null' + } + ); +} + +sub update_webhook_status { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + my $url = $opt{url}; + my $success = $opt{success}; + my $text = $opt{text}; + + if ( length($text) > 1000 ) { + $text = substr( $text, 0, 1000 ) . '…'; + } + + $db->update( + 'webhooks', + { + errored => $success ? 0 : 1, + latest_run => DateTime->now( time_zone => 'Europe/Berlin' ), + output => $text, + }, + { + user_id => $uid, + url => $url + } + ); +} + +sub set_profile { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + my $profile = $opt{profile}; + + $db->update( + 'users', + { profile => JSON->new->encode($profile) }, + { id => $uid } + ); +} + +sub get_profile { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + + return $db->select( 'users', ['profile'], { id => $uid } ) + ->expand->hash->{profile}; +} + +sub get_relation { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + my $subject = $opt{subject}; + my $object = $opt{object}; + + my $res_h = $db->select( + 'relations', + ['predicate'], + { + subject_id => $subject, + object_id => $object, + } + )->hash; + + if ($res_h) { + return $predicate_itoa{ $res_h->{predicate} }; + } + return; + + #my $res_h = $db->select( 'relations', ['subject_id', 'predicate'], + # { subject_id => [$uid, $target], object_id => [$target, $target] } )->hash; +} + +sub update_notifications { + my ( $self, %opt ) = @_; + + # must be called inside a transaction, so $opt{db} is mandatory. + my $db = $opt{db}; + my $uid = $opt{uid}; + + my $has_follow_requests = $opt{has_follow_requests} + // $self->has_follow_requests( + db => $db, + uid => $uid + ); + + my $notifications + = $db->select( 'users', ['notifications'], { id => $uid } ) + ->hash->{notifications}; + if ($has_follow_requests) { + $notifications |= 0x01; + } + else { + $notifications &= ~0x01; + } + $db->update( 'users', { notifications => $notifications }, { id => $uid } ); +} + +sub follow { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + my $target = $opt{target}; + + $db->insert( + 'relations', + { + subject_id => $uid, + predicate => $predicate_atoi{follows}, + object_id => $target, + ts => DateTime->now( time_zone => 'Europe/Berlin' ), + } + ); +} + +sub request_follow { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + my $target = $opt{target}; + + my $tx; + if ( not $opt{in_transaction} ) { + $tx = $db->begin; + } + + $db->insert( + 'relations', + { + subject_id => $uid, + predicate => $predicate_atoi{requests_follow}, + object_id => $target, + ts => DateTime->now( time_zone => 'Europe/Berlin' ), + } + ); + $self->update_notifications( + db => $db, + uid => $target, + has_follow_requests => 1, + ); + + if ($tx) { + $tx->commit; + } +} + +sub accept_follow_request { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + my $applicant = $opt{applicant}; + + my $tx; + if ( not $opt{in_transaction} ) { + $tx = $db->begin; + } + + $db->update( + 'relations', + { + predicate => $predicate_atoi{follows}, + ts => DateTime->now( time_zone => 'Europe/Berlin' ), + }, + { + subject_id => $applicant, + predicate => $predicate_atoi{requests_follow}, + object_id => $uid + } + ); + $self->update_notifications( + db => $db, + uid => $uid + ); + + if ($tx) { + $tx->commit; + } +} + +sub reject_follow_request { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + my $applicant = $opt{applicant}; + + my $tx; + if ( not $opt{in_transaction} ) { + $tx = $db->begin; + } + + $db->delete( + 'relations', + { + subject_id => $applicant, + predicate => $predicate_atoi{requests_follow}, + object_id => $uid + } + ); + $self->update_notifications( + db => $db, + uid => $uid + ); + + if ($tx) { + $tx->commit; + } +} + +sub cancel_follow_request { + my ( $self, %opt ) = @_; + + $self->reject_follow_request( + db => $opt{db}, + uid => $opt{target}, + applicant => $opt{uid}, + ); +} + +sub unfollow { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + my $target = $opt{target}; + + $db->delete( + 'relations', + { + subject_id => $uid, + predicate => $predicate_atoi{follows}, + object_id => $target + } + ); +} + +sub remove_follower { + my ( $self, %opt ) = @_; + + $self->unfollow( + db => $opt{db}, + uid => $opt{follower}, + target => $opt{uid}, + ); +} + +sub block { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + my $target = $opt{target}; + + my $tx; + if ( not $opt{in_transaction} ) { + $tx = $db->begin; + } + + $db->insert( + 'relations', + { + subject_id => $target, + predicate => $predicate_atoi{is_blocked_by}, + object_id => $uid, + ts => DateTime->now( time_zone => 'Europe/Berlin' ), + }, + { + on_conflict => \ +'(subject_id, object_id) do update set predicate = EXCLUDED.predicate' + }, + ); + $self->update_notifications( + db => $db, + uid => $uid + ); + + if ($tx) { + $tx->commit; + } +} + +sub unblock { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + my $target = $opt{target}; + + $db->delete( + 'relations', + { + subject_id => $target, + predicate => $predicate_atoi{is_blocked_by}, + object_id => $uid + }, + ); +} + +sub get_followers { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + + my $res = $db->select( + 'followers', + [ 'id', 'name', 'accept_follows', 'inverse_predicate' ], + { self_id => $uid } + ); + + my @ret; + while ( my $row = $res->hash ) { + push( + @ret, + { + id => $row->{id}, + name => $row->{name}, + following_back => ( + $row->{inverse_predicate} + and $row->{inverse_predicate} == $predicate_atoi{follows} + ) ? 1 : 0, + followback_requested => ( + $row->{inverse_predicate} + and $row->{inverse_predicate} + == $predicate_atoi{requests_follow} + ) ? 1 : 0, + can_follow_back => ( + not $row->{inverse_predicate} + and $row->{accept_follows} == 2 + ) ? 1 : 0, + can_request_follow_back => ( + not $row->{inverse_predicate} + and $row->{accept_follows} == 1 + ) ? 1 : 0, + } + ); + } + return @ret; +} + +sub has_followers { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + + return $db->select( 'followers', 'count(*) as count', { self_id => $uid } ) + ->hash->{count}; +} + +sub get_follow_requests { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + my $table = $opt{sent} ? 'tx_follow_requests' : 'rx_follow_requests'; + + my $res + = $db->select( $table, [ 'id', 'name' ], { self_id => $uid } ); + + return $res->hashes->each; +} + +sub has_follow_requests { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + my $table = $opt{sent} ? 'tx_follow_requests' : 'rx_follow_requests'; + + return $db->select( $table, 'count(*) as count', { self_id => $uid } ) + ->hash->{count}; +} + +sub get_followees { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + + my $res = $db->select( + 'followees', + [ 'id', 'name', 'inverse_predicate' ], + { self_id => $uid } + ); + + my @ret; + while ( my $row = $res->hash ) { + push( + @ret, + { + id => $row->{id}, + name => $row->{name}, + following_back => ( + $row->{inverse_predicate} + and $row->{inverse_predicate} == $predicate_atoi{follows} + ) ? 1 : 0, + } + ); + } + return @ret; +} + +sub has_followees { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + + return $db->select( 'followees', 'count(*) as count', { self_id => $uid } ) + ->hash->{count}; +} + +sub get_blocked_users { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + + my $res + = $db->select( 'blocked_users', [ 'id', 'name' ], { self_id => $uid } ); + + return $res->hashes->each; +} + +sub has_blocked_users { + my ( $self, %opt ) = @_; + + my $db = $opt{db} // $self->{pg}->db; + my $uid = $opt{uid}; + + return $db->select( 'blocked_users', 'count(*) as count', + { self_id => $uid } )->hash->{count}; +} + +1; |