Initial commit

2022-01-06 16:37:50 +03:00
commit 2428e6edff
18 changed files with 1179 additions and 0 deletions
--- a/lib/Conf.pm
+++ b/lib/Conf.pm
@@ -0,0 +1,37 @@
+package Conf;
+# loads config
+
+use 5.018;
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use Encode qw (encode);
+use JSON::XS;
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (LoadConf);
+
+sub LoadConf {
+	my $c = 'data/config.json';
+	open my $CH, '<', $c or die "[FATAL] No conf at $c: $OS_ERROR\n";
+	my $json;
+	my $len = (stat $c) [7];
+	my $readlen = read $CH, $json, $len;
+	$json = encode 'UTF-8', $json;
+
+	unless ($readlen) {
+		close $CH;                                   ## no critic (InputOutput::RequireCheckedSyscalls
+		die "[FATAL] Unable to read $c: $OS_ERROR\n";
+	}
+
+	close $CH;                                       ## no critic (InputOutput::RequireCheckedSyscalls
+	my $j = JSON::XS->new->utf8->relaxed;
+	return $j->decode ($json);
+}
+
+1;
+
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
--- a/lib/Games.pm
+++ b/lib/Games.pm
@@ -0,0 +1,173 @@
+package Games;
+
+# Общие модули - синтаксис, кодировки итд
+use 5.018;
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+
+# Модули для работы приложения
+use Clone qw (clone);
+use Data::Dumper;
+use Log::Any qw ($log);
+use Math::Random::Secure qw (irand);
+# Чтобы "уж точно" использовать hiredis-биндинги, загрузим этот модуль перед Mojo::Redis
+use Protocol::Redis::XS;
+use Mojo::Redis;
+use Mojo::IOLoop;
+use Mojo::IOLoop::Signal;
+
+use Conf qw (LoadConf);
+use Games::Archeologist qw (Dig);
+use Games::Fisher qw (Fish);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (RunGames);
+
+my $c = LoadConf ();
+my $fwd_cnt = $c->{'forward_max'} // 5;
+
+# Основной парсер
+my $parse_message = sub {
+	my $self = shift;
+	my $m = shift;
+	my $answer = clone ($m);
+	$answer->{from} = 'games';
+	$answer->{message} = undef;
+
+	if (defined $answer->{misc}) {
+		unless (defined $answer->{misc}->{fwd_cnt}) {
+			$answer->{misc}->{fwd_cnt} = 1;
+		} else {
+			if ($answer->{misc}->{fwd_cnt} > $fwd_cnt) {
+				$log->error ('Forward loop detected, discarding message.');
+				$log->debug (Dumper $m);
+				return;
+			} else {
+				$answer->{misc}->{fwd_cnt}++;
+			}
+		}
+
+		unless (defined $answer->{misc}->{answer}) {
+			$answer->{misc}->{answer} = 1;
+		}
+
+		unless (defined $answer->{misc}->{csign}) {
+			$answer->{misc}->{csign} = '!';
+		}
+	} else {
+		$answer->{misc}->{answer} = 1;
+		$answer->{misc}->{csign} = '!';
+		$answer->{misc}->{msg_format} = 0;
+	}
+
+	my $send_to = $m->{plugin};
+
+	$log->debug ('[DEBUG] Incoming message ' . Dumper ($m));
+
+	# Пробуем найти команды. Сообщения, начинающиеся с $answer->{misc}->{csign}
+	if (substr ($m->{message}, 0, 1) eq $answer->{misc}->{csign}) {
+		my $cmd = substr $m->{message}, 1;
+		my @cmds = qw (fish fishing рыба рыбка рыбалка);
+		my $bingo = 0;
+
+		while (my $check = pop @cmds) {
+			if ($cmd eq $check) {
+				$answer->{message} = Fish ($m->{misc}->{username});
+				$bingo = 1;
+				last;
+			}
+		}
+
+		unless ($bingo) {
+			$#cmds = -1;
+			@cmds = qw (dig копать раскопки);
+
+			while (my $check = pop @cmds) {
+				if ($cmd eq $check) {
+					$answer->{message} = Dig ($m->{misc}->{username});
+					$bingo = 1;
+					last;
+				}
+			}
+		}
+	}
+
+	$log->debug ("[DEBUG] Sending message to channel $send_to " . Dumper ($answer));
+
+	if (defined $answer->{message}) {
+		$self->json ($send_to)->notify (
+			$send_to => $answer
+		);
+	}
+
+	return;
+};
+
+my $__signal_handler = sub {
+	my ($self, $name) = @_;
+	$log->info ("[INFO] Caught a signal $name");
+
+	if (defined $main::pidfile && -f $main::pidfile) {
+		unlink $main::pidfile;
+	}
+
+	exit 0;
+};
+
+
+# main loop, он же event loop
+sub RunGames {
+	$log->info ("[INFO] Connecting to $c->{server}, $c->{port}");
+
+	my $redis = Mojo::Redis->new (
+		sprintf 'redis://%s:%s/1', $c->{server}, $c->{port}
+	);
+
+	$log->info ('[INFO] Registering connection-event callback');
+
+	$redis->on (
+		connection => sub {
+			my ($r, $connection) = @_;
+
+			$log->info ('[INFO] Triggering callback on new client connection');
+
+			# Залоггируем ошибку, если соединение внезапно порвалось.
+			$connection->on (
+				error => sub {
+					my ($conn, $error) = @_;
+					$log->error ("[ERROR] Redis connection error: $error");
+					return;
+				}
+			);
+
+			return;
+		}
+	);
+
+	my $pubsub = $redis->pubsub;
+	my $sub;
+	$log->info ('[INFO] Subscribing to redis channels');
+
+	foreach my $channel (@{$c->{channels}}) {
+		$log->debug ("[DEBUG] Subscribing to $channel");
+
+		$sub->{$channel} = $pubsub->json ($channel)->listen (
+			$channel => sub { $parse_message->(@_); }
+		);
+	}
+
+	Mojo::IOLoop::Signal->on (
+		TERM => $__signal_handler,
+		INT  => $__signal_handler
+	);
+
+	do { Mojo::IOLoop->start } until Mojo::IOLoop->is_running;
+	return;
+}
+
+1;
+
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
--- a/lib/Games/Archeologist.pm
+++ b/lib/Games/Archeologist.pm
@@ -0,0 +1,108 @@
+package Games::Archeologist;
+
+use 5.018;
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use DBI;
+use Log::Any qw ($log);
+use Math::Random::Secure qw (irand);
+
+use Conf qw (LoadConf);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (Dig);
+
+my $c = LoadConf ();
+my $gamestatdir = $c->{gamestat}->{gamestatdir};
+my $dbfile = sprintf '%s/gamestat.sqlite', $gamestatdir;
+
+
+sub getRandomArtifact {
+	my $dbh;
+	$dbh = DBI->connect ("dbi:SQLite:$dbfile", '', '') or do {
+		$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
+		return undef;
+	};
+
+	$dbh->{sqlite_unicode} = 1;
+
+	my $rows_affected = $dbh->do ('PRAGMA foreign_keys=ON') or do {
+		$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
+		return undef;
+	};
+
+	$rows_affected = $dbh->do ('PRAGMA journal_mode=WAL') or do {
+		$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
+		return undef;
+	};
+
+	my $ary_ref = $dbh->selectall_arrayref ('SELECT name FROM artifacts WHERE id > 0 AND id < 10000') or do {
+		$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
+		return undef;
+	};
+
+	$dbh->disconnect or $log->warn (sprintf '[WARN] Unable to close gamestat db, sqlite error: %s', $dbh->errstr);
+
+	return $ary_ref->[irand ($#{ $ary_ref } + 1)]->[0];
+}
+
+sub Dig {
+	my $name = shift;
+
+	my @location = (
+		'в архивах',
+		'в гималаях',
+		'в интернете',
+		'в кармане',
+		'в клумбе',
+		'в лунном кратере',
+		'во льдах арктики',
+		'в морге',
+		'в окрестностях погоста',
+		'в песочнице',
+		'в пустыне Гоби',
+		'в пустыне Сахаре',
+		'в русле высохшей реки',
+		'в собственной памяти',
+		'в старом сортире',
+		'в углу',
+		'в цветочном горшке',
+		'на бабушкином огороде',
+		'на винчестере',
+		'на горе Арарат',
+		'на горном плато',
+		'на дне моря',
+		'на необитаемом острове',
+		'на первом слое сумрака',
+		'на просторах Украины',
+	);
+
+	my $find_probability = irand 100;
+	my $success_probability = irand 100;
+	my $artifact_age = irand 15000;
+
+	if ($find_probability <= 20) {
+		return sprintf 'По уши закопавшись %s, %s, нифига вы не выкопали! Может повезет в другом месте?', $location[irand ($#location + 1)], $name;
+	}
+
+	my $phrase = sprintf "Вы начали раскопки %s и усиленно роете лопатами, экскаватором...\n", $location[irand ($#location + 1)];
+	$phrase .= "Вам кажется, что ваш совочек ударился обо что-то твердое. Может, это клад?!\n\n";
+	my $artifact = getRandomArtifact();
+
+	if ($success_probability <= 25) {
+		$phrase .= sprintf '%s стал лучшим археологом, выкопав %s! возраст артефакта - %s лет!', $name, $artifact, $artifact_age;
+	} else {
+		$phrase .= sprintf "Поздравляю, %s! Вы только что выкопали %s, возраст - %s лет!\n", $name, $artifact, $artifact_age;
+		$phrase .= sprintf 'Извини, %s, но на артефакт это не тянет! Однако, попытка хорошая!', $name;
+	}
+
+	return $phrase;
+}
+
+1;
+
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
--- a/lib/Games/Fisher.pm
+++ b/lib/Games/Fisher.pm
@@ -0,0 +1,122 @@
+package Games::Fisher;
+
+use 5.018;
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use DBI;
+use Log::Any qw ($log);
+use Math::Random::Secure qw (irand);
+
+use Conf qw (LoadConf);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (Fish);
+
+my $c = LoadConf ();
+my $gamestatdir = $c->{gamestat}->{gamestatdir};
+my $dbfile = sprintf '%s/gamestat.sqlite', $gamestatdir;
+
+
+sub getRandomArtifact {
+	my $dbh;
+	$dbh = DBI->connect ("dbi:SQLite:$dbfile", '', '') or do {
+		$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
+		return undef;
+	};
+
+	$dbh->{sqlite_unicode} = 1;
+
+	my $rows_affected = $dbh->do ('PRAGMA foreign_keys=ON') or do {
+		$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
+		return undef;
+	};
+
+	$rows_affected = $dbh->do ('PRAGMA journal_mode=WAL') or do {
+		$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
+		return undef;
+	};
+
+	my $ary_ref = $dbh->selectall_arrayref ('SELECT name FROM artifacts WHERE id > 9999 AND id < 20000') or do {
+		$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
+		return undef;
+	};
+
+	$dbh->disconnect or $log->warn (sprintf '[WARN] Unable to close gamestat db, sqlite error: %s', $dbh->errstr);
+
+	return $ary_ref->[irand ($#{ $ary_ref } + 1)]->[0];
+}
+
+
+sub Fish {
+	my $name = shift;
+
+	my @location = (
+		'в поток',
+		'в озеро',
+		'в реку',
+		'в северный ледовитый океан',
+		'в индийский океан',
+		'в биде',
+		'в детский плавательный бассейн',
+		'в туалет',
+		'в кучу рвоты',
+		'в лужу мочи',
+		'в раковину',
+		'в слив ванной',
+		'в лужу грязи',
+		'в ведро воды',
+		'в бутылку с водкой',
+		'в ванную',
+		'в бочку с дождевой водой',
+		'в аквариум',
+		'в сугроб',
+		'в водопад',
+		'в чашку кофе',
+		'в стакан молока',
+		'в черную дыру',
+		'дно Удомельского реактора',
+		'на Марс',
+		'в соседнюю галактику',
+		'к соседу на балкон',
+		'далеко-далеко',
+		'далеко и надолго',
+		'на крышу дома',
+	);
+
+	my @material = (
+		'бамбуковую',
+		'фибергласовую',
+		'карбоновую',
+		'композитную',
+	);
+
+	my $find_probability = irand 100;
+	my $success_probability = irand 100;
+	my $weight = irand 7000;
+
+	my $phrase = sprintf "Вы забрасываете %s удочку %s.\nВы чувствуете поклёвку и начинаете быстро тащить что-то.\n", $material[irand ($#material + 1)], $location[irand ($#location + 1)];
+
+	if ($find_probability <= 20) {
+		$phrase .= sprintf 'Черт, твоя рыбка сорвалась, %s! Не беда, может потом повезет?', $name;
+		return $phrase;
+	}
+
+	my $artifact = getRandomArtifact ();
+	$phrase .= sprintf "Поздравляю, %s! Вы только что поймали %s! аж на %d кило!\n\n", $name, $artifact, $weight;
+
+	if ($success_probability <= 25) {
+		$phrase .= sprintf 'Ё-мое!!! А это ведь новый рекорд! Продолжай в том же духе, %s!', $name;
+	} else {
+		$phrase .= sprintf 'Извини, %s, но это не новый рекорд! Однако, хорошая попытка!', $name;
+	}
+
+	return $phrase;
+}
+
+1;
+
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
--- a/lib/Games/Gamestat.pm
+++ b/lib/Games/Gamestat.pm
@@ -0,0 +1,116 @@
+package Games::Gamestat;
+# Stores and calculates player stats for games
+
+use 5.018;
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use DBI;
+use English qw ( -no_match_vars );
+use File::Path qw (make_path);
+use Mojo::Util qw (trim);
+use String::Random qw (random_string);
+
+use Conf qw (LoadConf);
+use Util qw (utf2sha1);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (SeedArtifacts);
+
+
+my $c = LoadConf ();
+my $dir = $c->{gamestat}->{dir};
+my $gamestatdir = $c->{gamestat}->{gamestatdir};
+my $dbfile = sprintf '%s/gamestat.sqlite', $gamestatdir;
+
+# assume that there is not too much artifacts.
+sub SeedArtifacts {
+	open (my $AFH, '<', "$dir/archeologic_artifacts.txt") || die "No $dir/archeologic_artifacts.txt\n";
+	my @arch_artifacts;
+
+	while (my $artifact = <$AFH>) {
+		next if ($artifact =~ /^\s*$/s);
+		$artifact = trim ($artifact);
+		push @arch_artifacts, $artifact;
+	}
+
+	close $AFH; ## no critic (InputOutput::RequireCheckedSyscalls)
+
+	open ($AFH, '<', "$dir/fisher_artifacts.txt") || die "No $dir/fisher_artifacts.txt\n";
+	my @fisher_artifacts;
+
+	while (my $artifact = <$AFH>) {
+		next if ($artifact =~ /^\s*$/s);
+		$artifact = trim ($artifact);
+		push @fisher_artifacts, $artifact;
+	}
+
+	close $AFH; ## no critic (InputOutput::RequireCheckedSyscalls)
+	undef $AFH;
+
+	my $tablename = random_string ('..........');
+	$tablename = utf2sha1 ($tablename);
+
+	while ($tablename =~ /^\d/s) {
+		$tablename = utf2sha1 ($tablename);
+	}
+
+	$tablename =~ s/[\/_\+]/a/sg;
+	$tablename = lc $tablename;
+
+	unless (-d $gamestatdir) {
+		make_path ($gamestatdir)  ||  die "Unable to create $gamestatdir: $OS_ERROR\n";
+	}
+
+	my $dbh = DBI->connect ("dbi:SQLite:$dbfile", '', '');
+	$dbh->{sqlite_unicode} = 1;
+	my $rows_affected = $dbh->do ('PRAGMA foreign_keys=ON') or die $dbh->errstr . "\n";
+	$rows_affected = $dbh->do ('PRAGMA journal_mode=WAL') or die $dbh->errstr . "\n";
+
+	# Open transaction
+	$dbh->begin_work or die $dbh->errstr . "\n";
+
+	my $query = <<"QUERY";
+CREATE TABLE IF NOT EXISTS $tablename (
+	id INT UNIQUE NOT NULL, -- artifact id
+	name TEXT PRIMARY KEY   -- artifact name
+);
+QUERY
+
+	$rows_affected = $dbh->do ($query) or die $dbh->errstr . "\n";
+	my $sth = $dbh->prepare ("REPLACE INTO $tablename(id,name) VALUES (?,?)") or die $dbh->errstr . "\n";
+
+	# Insert our archeological artifacts
+	my $counter = 0;
+
+	foreach my $artifact (@arch_artifacts) {
+		last if ($counter == 10000);
+		$sth->execute ($counter, $artifact);
+		$counter++;
+	}
+
+	# Insert our fishing artifacts
+	$counter = 10000;
+
+	foreach my $artifact (@fisher_artifacts) {
+		last if ($counter == 20000);
+		$sth->execute ($counter, $artifact);
+		$counter++;
+	}
+
+	# Add indexes
+	$rows_affected = $dbh->do ("CREATE INDEX IF NOT EXISTS myartifactid ON $tablename(id)") or die $dbh->errstr . "\n";
+
+	# Drop target table and replace it with our
+	$rows_affected = $dbh->do ('DROP TABLE IF EXISTS artifacts') or die $dbh->errstr . "\n";
+	$rows_affected = $dbh->do ("ALTER TABLE $tablename RENAME TO artifacts") or die $dbh->errstr . "\n";
+
+	# Close transaction
+	$dbh->commit or die $dbh->errstr . "\n";
+	$dbh->disconnect or warn sprintf ('[WARN] Unable to close gamestat db, sqlite error: %s', $dbh->errstr) . "\n";
+	return;
+}
+
+1;
--- a/lib/Util.pm
+++ b/lib/Util.pm
@@ -0,0 +1,30 @@
+package Util;
+
+use 5.018;
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+
+use Digest::SHA qw (sha1_base64);
+use Encode;
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (utf2sha1);
+
+sub utf2sha1 {
+	my $string = shift;
+
+	if ($string eq '') {
+		return sha1_base64 '';
+	}
+
+	my $bytes = encode_utf8 $string;
+	return sha1_base64 $bytes;
+}
+
+1;
+
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4: