Initial commit

.gitignore

@@ -0,0 +1,10 @@
+_Deparsed_XSubs.pm
+.idea/**
+.vscode/**
+.vstags
+*.pid
+*.log
+data/cache/**
+data/gamestat/**
+data/config.json
+vendor_perl/**

.perlcriticrc

@@ -0,0 +1,17 @@
+[-CodeLayout::RequireTidyCode]
+[-ValuesAndExpressions::ProhibitMagicNumbers]
+[-ControlStructures::ProhibitUnlessBlocks]
+[-ValuesAndExpressions::ProhibitNoisyQuotes]
+[-Variables::ProhibitPackageVars]
+[-NamingConventions::Capitalization]
+[-ControlStructures::ProhibitPostfixControls]
+[-InputOutput::RequireCheckedClose]
+[-Subroutines::ProhibitExcessComplexity]
+[-ValuesAndExpressions::RequireNumberSeparators]
+[-ValuesAndExpressions::ProhibitEmptyQuotes]
+[-RegularExpressions::RequireExtendedFormatting]
+[-RegularExpressions::RequireLineBoundaryMatching]
+[-Subroutines::ProhibitExplicitReturnUndef]
+[-RegularExpressions::ProhibitEscapedMetacharacters]
+[-InputOutput::RequireBriefOpen]
+[-Modules::ProhibitExcessMainComplexity]

LICENSE

@@ -0,0 +1,127 @@
+			 The "Artistic License"
+
+				Preamble
+
+The intent of this document is to state the conditions under which a
+Package may be copied, such that the Copyright Holder maintains some
+semblance of artistic control over the development of the package,
+while giving the users of the package the right to use and distribute
+the Package in a more-or-less customary fashion, plus the right to make
+reasonable modifications.
+
+Definitions:
+
+	"Package" refers to the collection of files distributed by the
+	Copyright Holder, and derivatives of that collection of files
+	created through textual modification.
+
+	"Standard Version" refers to such a Package if it has not been
+	modified, or has been modified in accordance with the wishes
+	of the Copyright Holder as specified below.
+
+	"Copyright Holder" is whoever is named in the copyright or
+	copyrights for the package.
+
+	"You" is you, if you're thinking about copying or distributing
+	this Package.
+
+	"Reasonable copying fee" is whatever you can justify on the
+	basis of media cost, duplication charges, time of people involved,
+	and so on.  (You will not be required to justify it to the
+	Copyright Holder, but only to the computing community at large
+	as a market that must bear the fee.)
+
+	"Freely Available" means that no fee is charged for the item
+	itself, though there may be fees involved in handling the item.
+	It also means that recipients of the item may redistribute it
+	under the same conditions they received it.
+
+1. You may make and give away verbatim copies of the source form of the
+Standard Version of this Package without restriction, provided that you
+duplicate all of the original copyright notices and associated disclaimers.
+
+2. You may apply bug fixes, portability fixes and other modifications
+derived from the Public Domain or from the Copyright Holder.  A Package
+modified in such a way shall still be considered the Standard Version.
+
+3. You may otherwise modify your copy of this Package in any way, provided
+that you insert a prominent notice in each changed file stating how and
+when you changed that file, and provided that you do at least ONE of the
+following:
+
+    a) place your modifications in the Public Domain or otherwise make them
+    Freely Available, such as by posting said modifications to Usenet or
+    an equivalent medium, or placing the modifications on a major archive
+    site such as uunet.uu.net, or by allowing the Copyright Holder to include
+    your modifications in the Standard Version of the Package.
+
+    b) use the modified Package only within your corporation or organization.
+
+    c) rename any non-standard executables so the names do not conflict
+    with standard executables, which must also be provided, and provide
+    a separate manual page for each non-standard executable that clearly
+    documents how it differs from the Standard Version.
+
+    d) make other distribution arrangements with the Copyright Holder.
+
+4. You may distribute the programs of this Package in object code or
+executable form, provided that you do at least ONE of the following:
+
+    a) distribute a Standard Version of the executables and library files,
+    together with instructions (in the manual page or equivalent) on where
+    to get the Standard Version.
+
+    b) accompany the distribution with the machine-readable source of
+    the Package with your modifications.
+
+    c) give non-standard executables non-standard names, and clearly
+    document the differences in manual pages (or equivalent), together
+    with instructions on where to get the Standard Version.
+
+    d) make other distribution arrangements with the Copyright Holder.
+
+5. You may charge a reasonable copying fee for any distribution of this
+Package.  You may charge any fee you choose for support of this
+Package.  You may not charge a fee for this Package itself.  However,
+you may distribute this Package in aggregate with other (possibly
+commercial) programs as part of a larger (possibly commercial) software
+distribution provided that you do not advertise this Package as a
+product of your own.  You may embed this Package's interpreter within
+an executable of yours (by linking); this shall be construed as a mere
+form of aggregation, provided that the complete Standard Version of the
+interpreter is so embedded.
+
+6. The scripts and library files supplied as input to or produced as
+output from the programs of this Package do not automatically fall
+under the copyright of this Package, but belong to whoever generated
+them, and may be sold commercially, and may be aggregated with this
+Package.  If such scripts or library files are aggregated with this
+Package via the so-called "undump" or "unexec" methods of producing a
+binary executable image, then distribution of such an image shall
+neither be construed as a distribution of this Package nor shall it
+fall under the restrictions of Paragraphs 3 and 4, provided that you do
+not represent such an executable image as a Standard Version of this
+Package.
+
+7. C subroutines (or comparably compiled subroutines in other
+languages) supplied by you and linked into this Package in order to
+emulate subroutines and variables of the language defined by this
+Package shall not be considered part of this Package, but are the
+equivalent of input as in Paragraph 6, provided these subroutines do
+not change the language in any way that would cause it to fail the
+regression tests for the language.
+
+8. Aggregation of this Package with a commercial distribution is always
+permitted provided that the use of this Package is embedded; that is,
+when no overt attempt is made to make this Package's interfaces visible
+to the end user of the commercial distribution.  Such use shall not be
+construed as a distribution of this Package.
+
+9. The name of the Copyright Holder may not be used to endorse or promote
+products derived from this software without specific prior written permission.
+
+10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+
+				The End

README

@@ -0,0 +1,37 @@
+aleesa-games
+-----------------------------------------------------------------------------------------------------------------------
+Различные текстовые игры:
+* Археолог
+* Рыбак
+
+Работает по протоколу Redis pubsub.
+
+
+Механика работы
+-----------------------------------------------------------------------------------------------------------------------
+Сервис подписан на канал games. В этот канал пишет другой демоночек - aleesa-misc.
+
+Ответ направляется в redis-канал, указанный в поле plugin входящего сообщения.
+
+Формат протокола - см README от aleesa-misc.
+
+
+Как это запустить?
+-----------------------------------------------------------------------------------------------------------------------
+Понадобится perl, cpanm и local::lib, а также несколько разных devel-пакетов для разных библиотек. Как правило, это
+находится методом тыка, но точно понадобятся zlib-devel, openssl-devel, hiredis-devel. Кроме того, понадобятся
+development tools - gcc, gcc-g++, perl-devel, make, cmake и так далее.
+
+Приложение тестировалось на alpine linux x86_64 3.12, со встроенным perl-5.32.1
+
+В каталоге с приложением под целевым пользователем запускаем bash bootstrap.sh Ждём с надеждой, что оно не обломится в
+пути.
+
+Если всё хорошо, то после создания data/config.json из data/config_sample.json и можно запускать приложение. Оно
+запустится как unix daemon.
+
+В каталоге contrib находится скрипт для alpine linux, системы инициализации openrc. Этот скрипт достаточно положить В
+/etc/init.d/aleesa-games сконфигурить сервис по инструкции выше и после этого сервис запускается командой:
+service aleesa-games start
+в автозагрузку его можно прописать через команду
+rc-update add aleesa-games default

bin/aleesa-games

@@ -0,0 +1,199 @@
+#!/usr/bin/perl
+
+use 5.018;
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+
+use version; our $VERSION = qw (1.0);
+
+my $workdir;
+
+# До фактического запуска логики программы, сменим рабочий каталог, чтобы подцепить либы
+BEGIN {
+	use Cwd qw (chdir abs_path);
+	my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
+
+	if ($#CWD > 1) {
+		$#CWD = $#CWD - 2;
+	}
+
+	$workdir = join '/', @CWD;
+	chdir $workdir;
+}
+
+use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
+no Cwd;
+use Cwd::utf8 qw (chdir abs_path);
+use File::Basename qw (basename dirname);
+use File::Path qw (make_path);
+use Log::Any qw ($log);
+use Log::Any::Adapter;
+use Log::Any::For::Std;
+use POSIX qw (setgid setuid setsid);
+
+use Conf qw (LoadConf);
+use Games qw (RunGames);
+
+sub daemonize;
+sub __fork;
+sub __signal_handler;
+
+local $OUTPUT_AUTOFLUSH = 1;
+my $runAsUid = $UID;
+
+my $piddir = '/var/run/' . basename (abs_path ($PROGRAM_NAME));
+my $C = LoadConf ();
+my $loglevel = $C->{'loglevel'} // 'notice';
+my $logfile;
+
+if (defined $C->{'log'}) {
+	$logfile = $C->{'log'};
+} elsif (defined $C->{'debug_log'}) {
+	$logfile = $C->{'debug_log'};
+}
+
+# Если мы запускаемся под рутом, то попробуем создать необходимые служебные каталоги и простать на них корректных
+# владельца и права
+if ($UID == 0) {
+	my $user = $C->{user};
+
+	unless (defined $user) {
+		die "Unable to run as root, please define unprivileged user in config.json\n";
+	}
+
+	my ($uid, $gid) = (getpwnam $user)[2,3];
+
+	unless (-d $piddir) {
+		make_path (
+			$piddir, {
+				uid   => $uid,
+				group => $gid
+			}
+		);
+	}
+
+	if (defined $logfile) {
+		my $logdir = dirname $logfile;
+
+		unless (-d $logdir) {
+			make_path (
+					$logdir, {
+							uid   => $uid,
+							group => $gid
+					}
+			) or die "Unable to create $logdir: $OS_ERROR\n";
+		}
+	}
+
+	# Переключаемся на "рабочего" пользователя и сбрасываем привилегии.
+	setgid ($gid) or die "Unable to switch to group of $user($OS_ERROR)\n";
+	setuid ($uid) or die "Unable to switch to account $user($OS_ERROR)\n";
+} else {
+	$piddir = $workdir;
+}
+
+if (defined $logfile) {
+	Log::Any::Adapter->set ('File', $logfile, log_level => $loglevel);
+
+	# Some annoying CHI logging events come with category set to CHI::Driver and log_level set to debug.
+	# Until we use start using Log::Any native features and set whole loglevel accordingly, lets lower
+	# verbosity paticulary for CHI.
+	Log::Any::Adapter->set (
+		{
+			category => 'CHI::Driver'
+		},
+		'File',
+		$logfile,
+		log_level => 'warn'
+	);
+} else {
+	Log::Any::Adapter->set ('File', '/dev/null');
+}
+
+# По-умолчанию, демонизируемся, если явно не указано, что этого делать не надо
+if (defined ($C->{daemonize}) && $C->{daemonize}) {
+	daemonize ();
+} elsif ( ! defined ($C->{daemonize})) {
+	daemonize ();
+}
+
+# Запишем pid-файл
+my $apath = abs_path $PROGRAM_NAME;
+
+unless (defined $apath) {
+	$log->fatal ("[FATAL] Unable to get abs_path: $OS_ERROR\n");
+	exit 1;
+};
+
+my $pidfile = sprintf '%s/%s.pid', $piddir, basename $apath;
+$log->info ("[INFO] Creating pidfile at $pidfile");
+
+open my $MYPID, '>', $pidfile or do {
+	$log->fatal ("[FATAL] Error opening $pidfile: $OS_ERROR");
+	exit 1;
+};
+
+print {$MYPID} $PID or do {
+	$log->fatal ("[FATAL] Error writing to $pidfile: $OS_ERROR");
+	exit 1;
+};
+
+close $MYPID;                                        ## no critic (InputOutput::RequireCheckedSyscalls
+
+local $SIG{INT}  = \&__signal_handler;
+local $SIG{TERM} = \&__signal_handler;
+
+# Поставим правильное имя процесса в proctitle
+$PROGRAM_NAME = abs_path $PROGRAM_NAME;              ## no critic (Variables::RequireLocalizedPunctuationVars)
+
+# И запустим уже наш сервис
+RunGames ();
+
+if (-f $pidfile) {
+	unlink $pidfile;
+}
+
+exit 0;
+
+sub daemonize {
+	__fork ();
+	POSIX::setsid ();
+	open STDIN, '<', '/dev/null';                    ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
+	# we handle STDOUT && STDERR via Log::Any::For::Std, so do not close them explicitly
+	#open STDOUT, '>', '/dev/null';                   ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
+	#open STDERR, '>', '/dev/null';                   ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
+	__fork ();
+	umask 0;
+	return;
+}
+
+sub __fork {
+	my $pid = fork;
+
+	unless (defined $pid) {
+		$log->fatal ("[FATAL] Can't fork: $OS_ERROR");
+		exit 1;
+	}
+
+	if ($pid != 0) {
+		exit;
+	}
+
+	return;
+}
+
+sub __signal_handler {
+	$log->info ("[INFO] Caught a signal $OS_ERROR");
+
+	if (-f $pidfile) {
+		unlink $pidfile;
+	}
+
+	exit 0;
+}
+
+__END__
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

bin/gamedata_seed.pl

@@ -0,0 +1,26 @@
+#!/usr/bin/perl
+
+use 5.018;
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use version; our $VERSION = qw (1.0);
+
+my $workdir;
+
+# before we run, change working dir
+BEGIN {
+	use Cwd qw (chdir abs_path);
+	my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
+	if ($#CWD > 1) { $#CWD = $#CWD - 2; }
+	$workdir = join '/', @CWD;
+	chdir $workdir;
+}
+
+use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
+use Games::Gamestat qw (SeedArtifacts);
+
+SeedArtifacts ();
+exit 0;

bootstrap.sh

@@ -0,0 +1,5 @@
+#!/bin/bash
+
+cpanm -l vendor_perl --self-contained --force --installdeps .
+
+# vim: set ft=sh noet ai ts=4 sw=4 sts=4:

contrib/aleesa-games.openrc

@@ -0,0 +1,11 @@
+#!/sbin/openrc-run
+
+name="$SVCNAME"
+command="/var/lib/$SVCNAME/bin/$SVCNAME"
+pidfile="/var/run/$SVCNAME/$SVCNAME.pid"
+
+depend() {
+	need net redis
+	use dns
+	after redis
+}

cpanfile

@@ -0,0 +1,28 @@
+requires 'Carp',                  '==1.50';
+requires 'Clone',                 '==0.45';
+requires 'Cwd::utf8',             '==0.011';
+requires 'DBD::SQLite',           '==1.70';
+requires 'DBI',                   '==1.643';
+requires 'Data::Dumper',          '==2.183';
+requires 'Digest::SHA',           '==6.02';
+requires 'Encode',                '==3.16';
+requires 'English',               '0';
+requires 'Exporter',              '==5.74';
+requires 'File::Basename',        '0';
+requires 'File::Path',            '==2.18';
+requires 'JSON::XS',              '==4.03';
+requires 'Log::Any',              '==1.710';
+requires 'Log::Any::Adapter',     '==1.710';
+requires 'Log::Any::For::Std',    '==0.05';
+requires 'Math::Random::Secure',  '==0.080001';
+requires 'Mojolicious',           '==9.22';
+requires 'Mojo::IOLoop',          '0';
+requires 'Mojo::IOLoop::Signal',  '==0.003';
+requires 'Mojo::Redis',           '==3.27';
+requires 'Mojo::Util',            '0';
+requires 'POSIX',                 '0';
+requires 'Protocol::Redis::XS',   '0';
+requires 'String::Random',        '==0.32';
+requires 'open',                  '0';
+requires 'utf8',                  '0';
+requires 'version',               '==0.9929';

data/archeologic_artifacts.txt

@@ -0,0 +1,54 @@
+амулет Мерлина
+библиотеку Ивана Грозного
+деревянную плошку
+диплока
+доски Ноева Ковчега
+древний презерватив из бараньей кишки
+икону
+инсталятор Windows 3.11
+истлевший гроб
+каменный топор
+клад со златом-серебром
+кривой нож
+ледяную глыбу
+лунный грунт
+мамонта
+мамонтёнка
+метеорит
+мумию фараона Тутанхамона
+носки прапорщика (поставит в угол)
+обломки грузинской керамики
+птеродактиля
+рубль с Лениным
+рыцарские доспехи
+синий мох
+скелет
+скелет собаки по кличке Беня
+тиранозавтра
+тотем индейцев
+трубу с туркменским газом
+скорбь еврейского народа
+залежи активированного угля
+не очень новый завет
+мать леннарта поттеринга
+руководство "начинающему археологу"
+слово о полку игореве и дело о полку игореве, вместе с игорем
+телепрограмму канала A-one
+могилу искателя могил
+заплесневевший кусок хлеба
+преемник радиоприемника
+глушитель от ВАЗ-2106
+чувство удовлетворения
+крота
+воспоминания о былой любви
+грязистор
+египетское мумиё
+окаменелый камень
+кладку яиц рептилоида
+яму
+чеснок и стрелы
+доллар по 30
+несмазанные скрижали
+четырелобита
+чучело тролля
+целое ничего

data/config_sample.json

@@ -0,0 +1,32 @@
+{
+    # redis address
+    "server" : "redis",
+    "port" : "6379",
+    "channels": [
+        "games"
+    ],
+
+    # should we fork() and become unix daemon?
+    "daemonize": 1,
+
+    # unprivileged system user to run bot as
+    "user" : "nobody",
+
+    # messages with commands will begin with this symbol
+    "csign": "!",
+
+    # logs goes there
+    "log" : "/var/log/aleesa-games/aleesa-games.log",
+    "loglevel": "info",
+
+    # ditto
+    "pid" : "/var/run/aleesa-games/aleesa-games.pid",
+
+    # maximal amount of message forwardings, to avoid endless loops
+    "forwards_max" : 5,
+
+    "gamestat" : {
+        "dir" : "data",
+        "gamestatdir" : "data/gamestat"
+    }
+}

data/fisher_artifacts.txt

@@ -0,0 +1,47 @@
+семикрылого чешуйчатого пятихуя
+разумного конденсатора
+сальмонеллу
+селёдку
+желтоперого тунца
+розовую сальмонеллу
+голавля
+барбуса
+окуня
+верхоплавку
+коричневую форель
+полярника
+плотву
+зубатку
+солнечную рыбу
+старую шину
+скользкую корягу
+лампу джина
+любовное послание в бутылке
+старое бревно
+резиновый сапог
+труп
+Лох-Несское чудовище
+старую рыбацкую приманку
+кусок Титаника
+обломок Атлантиды
+кита
+кальмара
+дельфина
+ската
+подводную лодку
+медузу
+морскую звезду
+электрического угря
+большую белую акулу
+аквалангиста
+монстра
+вируса
+сырую пачку сигарет
+водоросли
+якорь от лодки
+водяного
+русалку
+палтуса
+труп собаки по кличке Беня
+олигофрена Проню
+огеймера Фишкина

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:

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:

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:

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:

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;

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: