sergiotarxz/burguillos.info
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Adding geoip tracking.

Browse Source
This commit is contained in:
sergiotarxz 2023-08-08 19:39:13 +02:00
parent 6595b56726
commit fb75027c3e
5 changed files with 123 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
Build.PL
View File

@ -9,17 +9,18 @@ my $build = Module::Build->new(
dist_author => 'Sergio Iglesias <contact@owlcode.tech>',
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;

1
burguillos_info.json.example
View File

@ -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"
}

58
lib/BurguillosInfo/DB.pm
View File

@ -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

23
lib/BurguillosInfo/DB/Migrations.pm
View File

@ -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;

56
lib/BurguillosInfo/Tracking.pm
View File

@ -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;