From fb75027c3ebc93f662e7ebc6a4641c9f42deb875 Mon Sep 17 00:00:00 2001 From: sergiotarxz Date: Tue, 8 Aug 2023 19:39:13 +0200 Subject: [PATCH] Adding geoip tracking. --- Build.PL | 21 ++++++----- burguillos_info.json.example | 1 + lib/BurguillosInfo/DB.pm | 58 +++++++++++++++++------------ lib/BurguillosInfo/DB/Migrations.pm | 23 ++++++++++++ lib/BurguillosInfo/Tracking.pm | 56 ++++++++++++++++++++++++++-- 5 files changed, 123 insertions(+), 36 deletions(-) diff --git a/Build.PL b/Build.PL index 89e30b0..02e8ecd 100755 --- a/Build.PL +++ b/Build.PL @@ -9,17 +9,18 @@ my $build = Module::Build->new( dist_author => 'Sergio Iglesias ', dist_abstract => 'The burguillos.info webpage.', requires => { - 'Mojolicious' => 0, - 'Const::Fast' => 0, - 'Crypt::URandom' => 0, - 'Crypt::Bcrypt' => 0, - 'DBI' => 0, - 'DBD::Pg' => 0, + 'Mojolicious' => 0, + 'Const::Fast' => 0, + 'Crypt::URandom' => 0, + 'Crypt::Bcrypt' => 0, + 'DBI' => 0, + 'DBD::Pg' => 0, 'DateTime::Format::ISO8601.pm' => 0, - 'DateTime::Format::Mail.pm' => 0, - 'SVG' => 0, - 'XML::Twig' => 0, - 'JSON' => 0, + 'DateTime::Format::Mail.pm' => 0, + 'SVG' => 0, + 'XML::Twig' => 0, + 'JSON' => 0, + 'IP::Geolocation::MMDB' => 0, }, ); $build->create_build_script; diff --git a/burguillos_info.json.example b/burguillos_info.json.example index 58995ff..3551544 100644 --- a/burguillos_info.json.example +++ b/burguillos_info.json.example @@ -5,6 +5,7 @@ "database": "example" }, "base_url": "https://burguillos.info", + "geoip_database": "/usr/share/GeoLite2-City_20230804/GeoLite2-City.mmdb", "onion_base_url": "http://example.onion"; "listen": "https:localhost:3555" } diff --git a/lib/BurguillosInfo/DB.pm b/lib/BurguillosInfo/DB.pm index 2bbdfca..3020153 100644 --- a/lib/BurguillosInfo/DB.pm +++ b/lib/BurguillosInfo/DB.pm @@ -12,22 +12,28 @@ use BurguillosInfo::DB::Migrations; use Data::Dumper; my $dbh; + sub connect { - if (defined $dbh) { - return $dbh; + if ( defined $dbh ) { + return $dbh; } my $class = shift; my $app = shift; my $config = $app->config; my $database = $config->{db}{database}; - $dbh = DBI->connect( + $dbh = DBI->connect( "dbi:Pg:dbname=$database", - , undef, undef, { RaiseError => 1, Callbacks => { - connected => sub { - shift->do('set timezone = UTC'); - return; - } - }}, + , + undef, undef, + { + RaiseError => 1, + Callbacks => { + connected => sub { + shift->do('set timezone = UTC'); + return; + } + } + }, ); $class->_migrate($dbh); return $dbh; @@ -46,33 +52,39 @@ sub _migrate { say STDERR "Migrations already applied."; return; } - $class->_apply_migrations($dbh, \@migrations); + $class->_apply_migrations( $dbh, \@migrations ); } sub _apply_migrations { - my $class = shift; - my $dbh = shift; + my $class = shift; + my $dbh = shift; my $migrations = shift; for ( - my $i = $class->get_current_migration($dbh); + my $i = $class->get_current_migration($dbh) ; $i < @$migrations ; $i++ ) { - local $dbh->{RaiseError} = 1; - my $current_migration = $migrations->[$i]; - my $migration_number = $i + 1; - $class->_apply_migration($dbh, $current_migration, $migration_number); + local $dbh->{RaiseError} = 1; + my $current_migration = $migrations->[$i]; + my $migration_number = $i + 1; + $class->_apply_migration( $dbh, $current_migration, $migration_number ); } } sub _apply_migration { - my $class = shift; - my $dbh = shift; - my $current_migration = shift; - my $migration_number = shift; - $dbh->do($current_migration); - $dbh->do(<<'EOF', undef, 'current_migration', $migration_number); + my $class = shift; + my $dbh = shift; + my $current_migration = shift; + my $migration_number = shift; + { + if (ref $current_migration eq 'CODE') { + $current_migration->($dbh); + next; + } + $dbh->do($current_migration); + } + $dbh->do( <<'EOF', undef, 'current_migration', $migration_number ); INSERT INTO options VALUES ($1, $2) ON CONFLICT (name) DO diff --git a/lib/BurguillosInfo/DB/Migrations.pm b/lib/BurguillosInfo/DB/Migrations.pm index a860028..6dfccca 100644 --- a/lib/BurguillosInfo/DB/Migrations.pm +++ b/lib/BurguillosInfo/DB/Migrations.pm @@ -4,6 +4,9 @@ use v5.34.1; use strict; use warnings; +use utf8; + +use feature 'signatures'; sub MIGRATIONS { return ( @@ -31,6 +34,26 @@ sub MIGRATIONS { 'CREATE INDEX request_extra_index on requests (date, path);', 'ALTER TABLE requests ADD column referer text;', 'CREATE INDEX request_referer_index on requests (referer);', + 'ALTER TABLE requests ADD COLUMN country TEXT;', + 'CREATE INDEX request_country_index on requests (country);', + 'ALTER TABLE requests ADD COLUMN subdivision TEXT;', + 'CREATE INDEX request_subdivision_index on requests (subdivision);', + \&_populate_locations, ); } + +sub _populate_locations($dbh) { + require BurguillosInfo; + require BurguillosInfo::Tracking; + my $tracking = BurguillosInfo::Tracking->new(BurguillosInfo->new); + my $data = $dbh->selectall_arrayref(<<'EOF', {Slice => {}}); +SELECT uuid, remote_address +FROM requests +WHERE date > NOW() - interval '2 months'; +EOF + for my $request (@$data) { + my ($uuid, $remote_address) = $request->@{'uuid', 'remote_address'}; + $tracking->update_country_and_subdivision($dbh, $uuid, $remote_address); + } +} 1; diff --git a/lib/BurguillosInfo/Tracking.pm b/lib/BurguillosInfo/Tracking.pm index a3f442e..def0d25 100644 --- a/lib/BurguillosInfo/Tracking.pm +++ b/lib/BurguillosInfo/Tracking.pm @@ -54,13 +54,63 @@ sub _register_request_query ( $self, $remote_address, $user_agent, $params_json, $path, $referer ) { my $dbh = BurguillosInfo::DB->connect($app); + my $country = $self->_get_country('185.244.231.157'); + my $subdivision = $self->_get_subdivision('185.244.231.157'); + $dbh->do( - <<'EOF', undef, $remote_address, $user_agent, $params_json, $path, $referer ); -INSERT INTO requests(remote_address, user_agent, params, path, referer) - VALUES (?, ?, ?, ?, ?); + <<'EOF', undef, $remote_address, $user_agent, $params_json, $path, $referer, $country, $subdivision ); +INSERT INTO requests(remote_address, + user_agent, params, path, + referer, country, subdivision) + VALUES (?, ?, ?, ?, ?, ?, ?); EOF } +sub update_country_and_subdivision($self, $dbh, $uuid, $remote_address) { + my $country = $self->_get_country($remote_address); + my $subdivision = $self->_get_subdivision($remote_address); + $dbh->do(<<'EOF', undef, $country, $subdivision, $uuid); +UPDATE requests +SET country=?, + subdivision=? +WHERE uuid=?; +EOF +} + +sub _get_country($self, $remote_address) { + my $geoip = $self->_geoip; + if (!defined $geoip) { + return; + } + my $data = $geoip->record_for_address($remote_address); + return $data->{country}{names}{es}; +} + +sub _get_subdivision($self, $remote_address) { + my $geoip = $self->_geoip; + if (!defined $geoip) { + return; + } + my $data = $geoip->record_for_address($remote_address); + return $data->{subdivisions}[0]{names}{es}; +} + +sub _geoip($self) { + require IP::Geolocation::MMDB; + my $path = $self->_geoip_path; + if (!defined $path) { + return; + } + return IP::Geolocation::MMDB->new(file => $path); +} + +sub _geoip_path($self) { + require BurguillosInfo; + my $app = BurguillosInfo->new; + my $config = $app->config->{geoip_database}; + return $config; +} + sub register_request { my $self = shift; my $c = shift;