Adding geoip tracking.

Build.PL

@@ -20,6 +20,7 @@ my $build = Module::Build->new(
         'SVG'                          => 0,
         'XML::Twig'                    => 0,
         'JSON'                         => 0,
+        'IP::Geolocation::MMDB'        => 0,
     },
 );
 $build->create_build_script;

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

lib/BurguillosInfo/DB.pm

@@ -12,8 +12,9 @@ use BurguillosInfo::DB::Migrations;
 use Data::Dumper;
 
 my $dbh;
+
 sub connect {
-    if (defined $dbh) {
+    if ( defined $dbh ) {
         return $dbh;
     }
     my $class    = shift;
@@ -22,12 +23,17 @@ sub connect {
     my $database = $config->{db}{database};
     $dbh = DBI->connect(
         "dbi:Pg:dbname=$database",
-        , undef, undef, { RaiseError => 1, Callbacks => {
+        ,
+        undef, undef,
+        {
+            RaiseError => 1,
+            Callbacks  => {
                 connected => sub {
                     shift->do('set timezone = UTC');
                     return;
                 }
-	}},
+            }
+        },
     );
     $class->_migrate($dbh);
     return $dbh;
@@ -46,7 +52,7 @@ sub _migrate {
         say STDERR "Migrations already applied.";
         return;
     }
-    $class->_apply_migrations($dbh, \@migrations);
+    $class->_apply_migrations( $dbh, \@migrations );
 }
 
 sub _apply_migrations {
@@ -54,7 +60,7 @@ sub _apply_migrations {
     my $dbh        = shift;
     my $migrations = shift;
     for (
-        my $i = $class->get_current_migration($dbh);
+        my $i = $class->get_current_migration($dbh) ;
         $i < @$migrations ;
         $i++
       )
@@ -62,7 +68,7 @@ sub _apply_migrations {
         local $dbh->{RaiseError} = 1;
         my $current_migration = $migrations->[$i];
         my $migration_number  = $i + 1;
-	$class->_apply_migration($dbh, $current_migration, $migration_number);
+        $class->_apply_migration( $dbh, $current_migration, $migration_number );
     }
 }
 
@@ -71,8 +77,14 @@ sub _apply_migration {
     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);
+    }
+    $dbh->do( <<'EOF', undef, 'current_migration', $migration_number );
 INSERT INTO options
 VALUES ($1, $2) 
 ON CONFLICT (name) DO 

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;

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 );
+        <<'EOF', undef, $remote_address, $user_agent, $params_json, $path, $referer, $country, $subdivision );
-INSERT INTO requests(remote_address, user_agent, params, path, referer)
+INSERT INTO requests(remote_address,
-	VALUES (?, ?, ?, ?, ?);
+        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;