From 93be04122f14d0aebd0195def6603a6f2fc39b33 Mon Sep 17 00:00:00 2001 From: eleksir Date: Wed, 5 Jan 2022 19:06:34 +0300 Subject: [PATCH] Add Karma module --- .perlcriticrc | 3 ++ README | 2 +- cpanfile | 55 ++++++++++---------- data/config_sample.json | 3 ++ lib/Karma.pm | 111 ++++++++++++++++++++++++++++++++++++++++ lib/Phrases.pm | 33 ++++++++++-- 6 files changed, 175 insertions(+), 32 deletions(-) create mode 100644 lib/Karma.pm diff --git a/.perlcriticrc b/.perlcriticrc index 5c8964e..42ca195 100644 --- a/.perlcriticrc +++ b/.perlcriticrc @@ -49,3 +49,6 @@ [-ControlStructures::ProhibitCascadingIfElse] # just shut the fuck up + +[-Subroutines::ProhibitSubroutinePrototypes] +# i like it! \ No newline at end of file diff --git a/README b/README index 35ed413..e3527a6 100644 --- a/README +++ b/README @@ -4,7 +4,7 @@ aleesa-phrases * Фортунки (на основе фраз из fortune_mod) * Пятница * Пословицы и поговорки - +* Карма (вероятно, когда-нибудь поедет в отдельный модуль) Механика работы ----------------------------------------------------------------------------------------------------------------------- diff --git a/cpanfile b/cpanfile index 7042dab..13f3c7e 100644 --- a/cpanfile +++ b/cpanfile @@ -1,26 +1,29 @@ -requires 'Carp', '==1.50'; -requires 'Cwd::utf8', '==0.011'; -requires 'Data::Dumper', '==2.183'; -requires 'Encode', '==3.16'; -requires 'English', '==1.11'; -requires 'EV', '==4.33'; -requires 'File::Basename', '0'; -requires 'File::Path', '==2.18'; -requires 'JSON', '==4.03'; -requires 'JSON::XS', '==4.03'; -requires 'local::lib', '==2.000028'; -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 'open', '0'; -requires 'POSIX', '0'; -requires 'Protocol::Redis::XS', '0'; -requires 'SQLite_File', '==0.1006'; -requires 'utf8', '0'; -requires 'version', '0'; \ No newline at end of file +requires 'Carp', '==1.50'; +requires 'Clone', '==0.45'; +requires 'CHI', '==0.61'; +requires 'CHI::Driver::BerkeleyDB', '==0.05' ; +requires 'Cwd::utf8', '==0.011'; +requires 'Data::Dumper', '==2.183'; +requires 'Encode', '==3.16'; +requires 'English', '==1.11'; +requires 'EV', '==4.33'; +requires 'File::Basename', '0'; +requires 'File::Path', '==2.18'; +requires 'JSON', '==4.03'; +requires 'JSON::XS', '==4.03'; +requires 'local::lib', '==2.000028'; +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 'open', '0'; +requires 'POSIX', '0'; +requires 'Protocol::Redis::XS', '0'; +requires 'SQLite_File', '==0.1006'; +requires 'utf8', '0'; +requires 'version', '0'; \ No newline at end of file diff --git a/data/config_sample.json b/data/config_sample.json index f3e8033..69045f9 100644 --- a/data/config_sample.json +++ b/data/config_sample.json @@ -22,6 +22,9 @@ # maximal amount of message forwardings, to avoid endless loops "forwards_max" : 5, + # for karma + "cachedir" : "data/cache", + "fortune" : { "dir" : "data/fortune", "srcdir" : "data/fortune_src" diff --git a/lib/Karma.pm b/lib/Karma.pm new file mode 100644 index 0000000..2028d8c --- /dev/null +++ b/lib/Karma.pm @@ -0,0 +1,111 @@ +package Karma; + +use 5.018; +use strict; +use warnings; +use utf8; +use open qw (:std :utf8); + +use English qw ( -no_match_vars ); +use Carp qw (cluck); +use CHI; +use CHI::Driver::BerkeleyDB; +use Log::Any qw ($log); +use Mojo::Util qw (trim); + +use Conf qw (LoadConf); + +use version; our $VERSION = qw (1.0); +use Exporter qw (import); +our @EXPORT_OK = qw (KarmaSet KarmaGet); + +my $c = LoadConf (); +my $cachedir = $c->{cachedir}; +my $max = 5; + +# swallow phrase and return answer +sub KarmaSet (@) { + my $chatid = shift; + my $phrase = shift; + my $action = shift; + + $phrase = trim ($phrase); + + if ((! defined $phrase) || $phrase eq '') { + $phrase = ' '; + } + + my $cache = CHI->new ( + driver => 'BerkeleyDB', + root_dir => $cachedir, + namespace => __PACKAGE__ . '_' . $chatid + ); + + my $score = $cache->get ($phrase); + + if (defined $score) { + if ($action eq '++') { + $score++; + } else { + $score--; + } + } else { + if ($action eq '++') { + $score = 1; + } else { + $score = -1; + } + } + + if ($cache->set ($phrase, $score, 'never') != $score) { + $log->error ('[ERROR] Cache error: unable to set karma.'); + } + + if ($score < -1 && (($score % (0 - $max)) + 1) == 0) { + if ($phrase eq ' ') { + return sprintf 'Зарегистрировано пробитие дна, карма пустоты составляет %d', $score; + } else { + return sprintf 'Зарегистрировано пробитие дна, карма %s составляет %d', $phrase, $score; + } + } else { + if ($phrase eq ' ') { + return sprintf 'Карма пустоты составляет %d', $score; + } else { + return sprintf 'Карма %s составляет %d', $phrase, $score; + } + } +} + +# just return answer +sub KarmaGet (@) { + my $chatid = shift; + my $phrase = shift; + + $phrase = trim ($phrase); + + if ((! defined $phrase) || $phrase eq '') { + $phrase = ' '; + } + + my $cache = CHI->new ( + driver => 'BerkeleyDB', + root_dir => $cachedir, + namespace => __PACKAGE__ . '_' . $chatid + ); + + my $score = $cache->get ($phrase); + + unless (defined $score) { + $score = 0; + } + + if ($phrase eq ' ') { + return sprintf 'Карма пустоты составляет %d', $score; + } else { + return sprintf 'Карма %s составляет %d', $phrase, $score; + } +} + +1; + +# vim: ft=perl noet ai ts=4 sw=4 sts=4: diff --git a/lib/Phrases.pm b/lib/Phrases.pm index dc897a5..132a598 100644 --- a/lib/Phrases.pm +++ b/lib/Phrases.pm @@ -8,6 +8,7 @@ use utf8; use open qw (:std :utf8); # Модули для работы приложения +use Clone qw (clone); use Log::Any qw ($log); use Math::Random::Secure qw (irand); # Чтобы "уж точно" использовать hiredis-биндинги, загрузим этот модуль перед Mojo::Redis @@ -21,6 +22,7 @@ use Data::Dumper; use Conf qw (LoadConf); use Fortune qw (Fortune); use Friday qw (Friday); +use Karma qw (KarmaGet KarmaSet); use Proverb qw (Proverb); use version; our $VERSION = qw (1.0); @@ -34,7 +36,7 @@ my $fwd_cnt = $c->{'forward_max'} // 5; my $parse_message = sub { my $self = shift; my $m = shift; - my $answer = $m; + my $answer = clone ($m); $answer->{from} = 'phrases'; my $send_to = $m->{plugin}; my $reply; @@ -67,13 +69,15 @@ my $parse_message = sub { $log->debug ('[DEBUG] Incoming message ' . Dumper ($m)); + # Нормальная команда if (substr ($m->{message}, 0, 1) eq $answer->{misc}->{csign}) { - if (substr ($m->{message}, 1) eq 'friday' || substr ($m->{message}, 1) eq 'пятница') { + my $cmd = substr ($m->{message}, 1); + + if ($cmd eq 'friday' || $cmd eq 'пятница') { $reply = Friday (); - } elsif (substr ($m->{message}, 1) eq 'proverb' || substr ($m->{message}, 1) eq 'пословица') { + } elsif ($cmd eq 'proverb' || $cmd eq 'пословица') { $reply = Proverb (); - } elsif (substr ($m->{message}, 1) eq 'fortune' || substr ($m->{message}, 1) eq 'фортунка' || - substr ($m->{message}, 1) eq 'f' || substr ($m->{message}, 1) eq 'ф') { + } elsif ($cmd eq 'fortune' || $cmd eq 'фортунка' || $cmd eq 'f' || $cmd eq 'ф') { if ($m->{plugin} eq 'telegram') { if ($m->{misc}->{good_morning}){ # fortune mod @@ -90,6 +94,25 @@ my $parse_message = sub { } else { $reply = trim (Fortune ()); } + } elsif ($cmd =~ /^(karma|карма)\s(.+)/su) { + # TODO: избавиться от регулярки в пользу манипуляци со строкой через substr + $reply = KarmaGet ($m->{chatid}, $2); + } + # Скорее всего изменение кармы, но это не точно + } elsif (substr ($m->{message}, -2) eq '++' || substr ($m->{message}, -2) eq '--') { + my @arr = split /\n/s, $m->{message}; + + # Предполагается, что фраза - это только одна строка + if ($#arr < 1) { + $reply = KarmaSet ( + $m->{chatid}, + trim (substr $m->{message}, 0, -2), + substr $m->{message}, -2 + ); + # Если у нас более одной строки - пусть с этим разбирается craniac, у него есть *мозги* + } else { + $send_to = 'craniac'; + $reply = $m->{message}; } }