commit 2428e6edffe64e4acf9d9b480b4dc052e5ca3e2e Author: eleksir Date: Thu Jan 6 16:37:50 2022 +0300 Initial commit diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..28eaef4 --- /dev/null +++ b/.gitignore @@ -0,0 +1,10 @@ +_Deparsed_XSubs.pm +.idea/** +.vscode/** +.vstags +*.pid +*.log +data/cache/** +data/gamestat/** +data/config.json +vendor_perl/** diff --git a/.perlcriticrc b/.perlcriticrc new file mode 100644 index 0000000..5c50483 --- /dev/null +++ b/.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] \ No newline at end of file diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..4ff3f42 --- /dev/null +++ b/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 diff --git a/README b/README new file mode 100644 index 0000000..fb46881 --- /dev/null +++ b/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 diff --git a/bin/aleesa-games b/bin/aleesa-games new file mode 100755 index 0000000..172c47d --- /dev/null +++ b/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: diff --git a/bin/gamedata_seed.pl b/bin/gamedata_seed.pl new file mode 100644 index 0000000..608a191 --- /dev/null +++ b/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; diff --git a/bootstrap.sh b/bootstrap.sh new file mode 100644 index 0000000..eb5740a --- /dev/null +++ b/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: diff --git a/contrib/aleesa-games.openrc b/contrib/aleesa-games.openrc new file mode 100644 index 0000000..751365a --- /dev/null +++ b/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 +} diff --git a/cpanfile b/cpanfile new file mode 100644 index 0000000..af53140 --- /dev/null +++ b/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'; diff --git a/data/archeologic_artifacts.txt b/data/archeologic_artifacts.txt new file mode 100644 index 0000000..b08628b --- /dev/null +++ b/data/archeologic_artifacts.txt @@ -0,0 +1,54 @@ +амулет Мерлина +библиотеку Ивана Грозного +деревянную плошку +диплока +доски Ноева Ковчега +древний презерватив из бараньей кишки +икону +инсталятор Windows 3.11 +истлевший гроб +каменный топор +клад со златом-серебром +кривой нож +ледяную глыбу +лунный грунт +мамонта +мамонтёнка +метеорит +мумию фараона Тутанхамона +носки прапорщика (поставит в угол) +обломки грузинской керамики +птеродактиля +рубль с Лениным +рыцарские доспехи +синий мох +скелет +скелет собаки по кличке Беня +тиранозавтра +тотем индейцев +трубу с туркменским газом +скорбь еврейского народа +залежи активированного угля +не очень новый завет +мать леннарта поттеринга +руководство "начинающему археологу" +слово о полку игореве и дело о полку игореве, вместе с игорем +телепрограмму канала A-one +могилу искателя могил +заплесневевший кусок хлеба +преемник радиоприемника +глушитель от ВАЗ-2106 +чувство удовлетворения +крота +воспоминания о былой любви +грязистор +египетское мумиё +окаменелый камень +кладку яиц рептилоида +яму +чеснок и стрелы +доллар по 30 +несмазанные скрижали +четырелобита +чучело тролля +целое ничего diff --git a/data/config_sample.json b/data/config_sample.json new file mode 100644 index 0000000..1948fca --- /dev/null +++ b/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" + } +} diff --git a/data/fisher_artifacts.txt b/data/fisher_artifacts.txt new file mode 100644 index 0000000..b2f730c --- /dev/null +++ b/data/fisher_artifacts.txt @@ -0,0 +1,47 @@ +семикрылого чешуйчатого пятихуя +разумного конденсатора +сальмонеллу +селёдку +желтоперого тунца +розовую сальмонеллу +голавля +барбуса +окуня +верхоплавку +коричневую форель +полярника +плотву +зубатку +солнечную рыбу +старую шину +скользкую корягу +лампу джина +любовное послание в бутылке +старое бревно +резиновый сапог +труп +Лох-Несское чудовище +старую рыбацкую приманку +кусок Титаника +обломок Атлантиды +кита +кальмара +дельфина +ската +подводную лодку +медузу +морскую звезду +электрического угря +большую белую акулу +аквалангиста +монстра +вируса +сырую пачку сигарет +водоросли +якорь от лодки +водяного +русалку +палтуса +труп собаки по кличке Беня +олигофрена Проню +огеймера Фишкина diff --git a/lib/Conf.pm b/lib/Conf.pm new file mode 100644 index 0000000..9f6928c --- /dev/null +++ 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: diff --git a/lib/Games.pm b/lib/Games.pm new file mode 100644 index 0000000..603314b --- /dev/null +++ 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: diff --git a/lib/Games/Archeologist.pm b/lib/Games/Archeologist.pm new file mode 100644 index 0000000..1bbedfb --- /dev/null +++ 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: diff --git a/lib/Games/Fisher.pm b/lib/Games/Fisher.pm new file mode 100644 index 0000000..cca30fd --- /dev/null +++ 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: diff --git a/lib/Games/Gamestat.pm b/lib/Games/Gamestat.pm new file mode 100644 index 0000000..7150364 --- /dev/null +++ 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; diff --git a/lib/Util.pm b/lib/Util.pm new file mode 100644 index 0000000..6a8b8f7 --- /dev/null +++ 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: