aleesa-bot/aleesa-telegram
0
Fork 0
Code Pull Requests Projects Releases Activity

Move web client and karma plugins to redis rails, remove unneeded data and perl modules

Browse Source
This commit is contained in:
eleksir
2022-01-04 05:28:09 +03:00
parent c68f716cbb
commit ca946c7e7b
36 changed files with 336 additions and 6553 deletions
Download Patch File Download Diff File Expand all files Collapse all files

255
lib/BotLib.pm
View File

@@ -15,48 +15,18 @@ use Log::Any qw ($log);
use BotLib::Conf qw (LoadConf);
use BotLib::Admin qw (@ForbiddenMessageTypes GetForbiddenTypes AddForbiddenType
DelForbiddenType ListForbidden FortuneToggle FortuneStatus
PluginToggle PluginStatus PluginEnabled);
use BotLib::Anek qw (Anek);
PluginToggle PluginStatus PluginEnabled ChanMsgToggle ChanMsgStatus);
use BotLib::Archeologist qw (Dig);
use BotLib::Buni qw (Buni);
use BotLib::Drink qw (Drink);
use BotLib::Fisher qw (Fish);
use BotLib::Fortune qw (Fortune);
use BotLib::Friday qw (Friday);
use BotLib::Image qw (Kitty Fox Oboobs Obutts Rabbit Owl Frog Horse Snail);
use BotLib::Karma qw (KarmaSet KarmaGet);
use BotLib::Lat qw (Lat);
use BotLib::Monkeyuser qw (Monkeyuser);
use BotLib::Proverb qw (Proverb);
use BotLib::Util qw (trim);
use BotLib::Weather qw (Weather);
use BotLib::Xkcd qw (Xkcd);
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (RandomCommonPhrase Command Highlight BotSleep IsCensored);
our @EXPORT_OK = qw (Command Highlight BotSleep IsCensored);
my $c = LoadConf ();
my $csign = $c->{telegrambot}->{csign};
sub RandomCommonPhrase {
my @myphrase = (
'Так, блядь...',
'*Закатывает рукава* И ради этого ты меня позвал?',
'Ну чего ты начинаешь, нормально же общались',
'Повтори свой вопрос, не поняла',
'Выйди и зайди нормально',
'Я подумаю',
'Даже не знаю, что на это ответить',
'Ты упал такие вопросы девочке задавать?',
'Можно и так, но не уверена',
'А как ты думаешь?',
'А ви, таки, почему интересуетесь?',
);
return $myphrase[irand ($#myphrase + 1)];
}
sub Command {
my $self = shift;
my $msg = shift;
@@ -79,15 +49,65 @@ sub Command {
$rmsg->{mode} = 'public';
}
if ((substr ($text, 1) eq 'ping') || (substr ($text, 1) eq 'пинг') || (substr ($text, 1) eq 'pong') ||
(substr ($text, 1) eq 'понг') || (substr ($text, 1) eq 'coin' || substr ($text, 1) eq 'монетка') ||
(substr ($text, 1) eq 'roll' || substr ($text, 1) eq 'dice' || substr ($text, 1) eq 'кости') ||
(substr ($text, 1) eq 'ver' || substr ($text, 1) eq 'version' || substr ($text, 1) eq 'версия') ||
(substr ($text, 1) eq 'хэлп' || substr ($text, 1) eq 'halp') ||
(substr ($text, 1) eq 'kde' || substr ($text, 1) eq 'кде') ) {
my $cmd = substr $text, 1;
my @cmds = qw (tits boobs tities boobies сиси сисечки butt booty ass попа попка);
while (my $check = pop @cmds) {
if ($cmd eq $check) {
unless (PluginEnabled $chatid, 'oboobs') {
return;
}
}
}
$#cmds = -1;
@cmds = qw (butt booty ass попа попка);
while (my $check = pop @cmds) {
if ($cmd eq $check) {
unless (PluginEnabled $chatid, 'obutts') {
return;
}
}
}
$#cmds = -1;
@cmds = qw (ping пинг пинх pong понг понх coin монетка roll dice кости ver version версия хэлп halp kde кде lat
лат friday пятница proverb пословица fortune фортунка f ф anek анек анекдот buni cat кис drink праздник fox лис
frog лягушка horse лошадь лошадка monkeyuser owl сова сыч rabbit bunny кролик snail улитка tits boobs tities
boobies сиси сисечки butt booty ass попа попка xkcd);
my $bingo = 0;
while (my $check = pop @cmds) {
if ($cmd eq $check) {
$bingo = 1;
last;
}
}
# TODO: Заменить на сравнение со строкой?
if (($cmd =~ /^w\s/u) || ($cmd =~ /^п\s/u) || ($cmd =~ /^weather\s/u) || ($cmd =~ /^погода\s/u) ||
($cmd =~ /^погодка\s/u) || ($cmd =~ /^погадка\s/u) || ($cmd =~ /^karma\s/u) || ($cmd =~ /карма\s/u)) {
$bingo = 1;
}
if ($bingo) {
$rmsg->{message} = $text;
$self->log->debug ('[DEBUG] Sending message to redis ' . Dumper ($rmsg));
$#cmds = -1;
@cmds = qw (fortune фортунка f ф anek анек анекдот buni cat кис fox лис frog лягушка horse лошадь
лошадка monkeyuser owl сова сыч rabbit bunny кролик snail улитка tits boobs tities boobies сиси сисечки
butt booty ass попа попка xkcd);
while (my $check = pop @cmds) {
if ($cmd eq $check) {
$rmsg->{misc}->{msg_format} = 1;
last;
}
}
{
do {
my $ready = eval { $main::RCONN->is_connected; };
@@ -100,139 +120,6 @@ sub Command {
$pubsub->json ($c->{'redis_router_channel'})->notify (
$c->{'redis_router_channel'} => $rmsg
);
} elsif (substr ($text, 1) eq 'anek' || substr ($text, 1) eq 'анек' || substr ($text, 1) eq 'анекдот') {
$msg->typing ();
$reply = "```\n" . Anek () . "\n```";
sleep (irand (2) + 1);
$msg->replyMd ($reply);
return;
} elsif (length ($text) >= 2 && (substr ($text, 1, 2) eq 'w ' || substr ($text, 1, 2) eq 'п ')) {
my $city = substr $text, 3;
$reply = Weather $city;
} elsif (substr ($text, 1, 7) eq 'погода ') {
my $city = substr $text, 7;
$reply = Weather $city;
} elsif ((substr ($text, 1, 8) eq 'погодка ') || (substr ($text, 1, 8) eq 'погадка ') || (substr ($text, 1, 8) eq 'weather ')){
my $city = substr $text, 8;
$reply = Weather $city;
} elsif (substr ($text, 1) eq 'buni') {
$msg->typing ();
$reply = Buni ();
sleep (irand (2) + 1);
$msg->replyMd ($reply);
return;
} elsif (substr ($text, 1) eq 'monkeyuser') {
$msg->typing ();
$reply = Monkeyuser ();
sleep (irand (2) + 1);
$msg->replyMd ($reply);
return;
} elsif (substr ($text, 1) eq 'cat' || substr ($text, 1) eq 'кис') {
$msg->typing ();
$reply = Kitty ();
sleep (irand (2) + 1);
$msg->replyMd ($reply);
return;
} elsif (substr ($text, 1) eq 'frog' || substr ($text, 1) eq 'toad' || substr ($text, 1) eq 'лягушка') {
$msg->typing ();
$reply = Frog ();
sleep (irand (2) + 1);
$msg->replyMd ($reply);
return;
} elsif (substr ($text, 1) eq 'horse' || substr ($text, 1) eq 'лошадка') {
$msg->typing ();
$reply = Horse ();
sleep (irand (2) + 1);
$msg->replyMd ($reply);
return;
} elsif (substr ($text, 1) eq 'snail' || substr ($text, 1) eq 'улитка') {
$msg->typing ();
$reply = Snail ();
sleep (irand (2) + 1);
$msg->replyMd ($reply);
return;
} elsif (substr ($text, 1) eq 'lat' || substr ($text, 1) eq 'лат') {
$reply = Lat ();
} elsif (
(length ($text) >= 6 && (substr ($text, 1, 6) eq 'karma ' || substr ($text, 1, 6) eq 'карма ')) ||
substr ($text, 1) eq 'karma' || substr ($text, 1) eq 'карма'
) {
my $mytext = '';
if (length($text) > 6) {
$mytext = substr $text, 7;
chomp $mytext;
$mytext = trim $mytext;
} else {
$mytext = '';
}
$reply = KarmaGet ($chatid, $mytext);
} elsif (substr ($text, 1) eq 'xkcd') {
$msg->typing ();
$reply = Xkcd ();
sleep (irand (2) + 1);
$msg->replyMd ($reply);
return;
} elsif (substr ($text, 1) eq 'fox' || substr ($text, 1) eq 'лис') {
$msg->typing ();
$reply = Fox ();
sleep (irand (2) + 1);
$msg->replyMd ($reply);
return;
} elsif (substr ($text, 1) eq 'rabbit' || substr ($text, 1) eq 'bunny' || substr ($text, 1) eq 'кролик') {
$msg->typing ();
$reply = Rabbit ();
$msg->replyMd ($reply);
return;
} elsif (substr ($text, 1) eq 'owl' || substr ($text, 1) eq 'сова') {
$msg->typing ();
$reply = Owl ();
$msg->replyMd ($reply);
return;
} elsif (
substr ($text, 1) eq 'tits' ||
substr ($text, 1) eq 'boobs' ||
substr ($text, 1) eq 'tities' ||
substr ($text, 1) eq 'boobies' ||
substr ($text, 1) eq 'сиси' ||
substr ($text, 1) eq 'сисечки'
) {
if (PluginEnabled $chatid, 'oboobs') {
$msg->typing ();
$reply = Oboobs ();
sleep (irand (2) + 1);
$msg->replyMd ($reply);
}
return;
} elsif (
substr ($text, 1) eq 'butt' ||
substr ($text, 1) eq 'booty' ||
substr ($text, 1) eq 'ass' ||
substr ($text, 1) eq 'попа' ||
substr ($text, 1) eq 'попка'
) {
if (PluginEnabled $chatid, 'obutts') {
$msg->typing ();
$reply = Obutts ();
sleep (irand (2) + 1);
$msg->replyMd ($reply);
}
return;
} elsif (substr ($text, 1) eq 'friday' || substr ($text, 1) eq 'пятница') {
$reply = Friday ();
} elsif (substr ($text, 1) eq 'proverb' || substr ($text, 1) eq 'пословица') {
$reply = Proverb ();
} elsif (substr ($text, 1) eq 'fortune' || substr ($text, 1) eq 'фортунка' || substr ($text, 1) eq 'f' || substr ($text, 1) eq 'ф') {
$reply = sprintf "```\n%s\n```\n", trim (Fortune ());
$msg->replyMd ($reply);
return;
} elsif (substr ($text, 1) eq 'drink' || substr ($text, 1) eq 'праздник') {
$msg->typing ();
$reply = Drink ();
sleep (irand (2) + 1);
} elsif (substr ($text, 1) eq 'dig' || substr ($text, 1) eq 'копать') {
$msg->typing ();
$reply = Dig $highlight;
@@ -266,17 +153,17 @@ ${csign}frog | ${csign}лягушка - лягушка
${csign}horse | ${csign}лошадка - лошадка
${csign}lat | ${csign}лат - сгенерить фразу из крылатых латинских выражений
${csign}monkeyuser - рандомный стрип MonkeyUser
${csign}owl | ${csign}сова - сова
${csign}owl | ${csign}сова | ${csign}сыч - сова
${csign}proverb | ${csign}пословица - рандомная русская пословица
${csign}ping | ${csign}пинг - попинговать бота
${csign}roll | ${csign}dice | ${csign}кости - бросить кости
${csign}snail | ${csign}улитка - улитка
${csign}ver | ${csign}version | ${csign}версия - что-то про версию ПО
${csign}w город | ${csign}п город - погода в указанном городе
${csign}weather город - погода в указанном городе
${csign}погода город - погода в указанном городе
${csign}погодка город - погода в указанном городе
${csign}погадка город - погода в указанном городе
${csign}weather город - погода в указанном городе
${csign}погода город - погода в указанном городе
${csign}погодка город - погода в указанном городе
${csign}погадка город - погода в указанном городе
${csign}xkcd - рандомный стрип с сайта xkcd.ru
${csign}karma фраза | ${csign}карма фраза - посмотреть карму фразы
фраза-- | фраза++ - убавить или добавить карму фразе
@@ -305,6 +192,8 @@ ${csign}admin oboobs # - где 1 - вкл, 0 - выкл плагина obo
${csign}admin oboobs - показываем ли сисечки по просьбе участников чата (команды ${csign}tits, ${csign}tities, ${csign}boobs, ${csign}boobies, ${csign}сиси, ${csign}сисечки)
${csign}admin obutts # - где 1 - вкл, 0 - выкл плагина obutts
${csign}admin obutts - показываем ли попки по просьбе участников чата (команды ${csign}ass, ${csign}butt, ${csign}booty, ${csign}попа, ${csign}попка)
${csign}admin chan_msg - оставляем ли сообщения присланные от имени (других) каналов
${csign}admin chan_msg # - где 1 - оставляем, 0 - удаляем
```
Типы сообщений:
audio voice photo video animation sticker dice game poll document
@@ -320,7 +209,9 @@ MYADMIN
# this msg should be shown only if admins of chat request it
if (($member->status eq 'administrator') || ($member->status eq 'creator')) {
my $command = trim (substr $text, 7);
my ($cmd, $args) = split /\s+/, $command, 2;
$cmd = undef;
my $args;
($cmd, $args) = split /\s+/, $command, 2;
if ($cmd eq '') {
return;
@@ -354,6 +245,16 @@ MYADMIN
} else {
$reply = FortuneStatus ($chatid);
}
} elsif ($cmd eq 'chan_msg') {
if (defined $args) {
if ($args == 1) {
$reply = ChanMsgToggle ($chatid, 1);
} elsif ($args == 0) {
$reply = ChanMsgToggle ($chatid, 0);
}
} else {
$reply = ChanMsgStatus ($chatid);
}
} elsif ($cmd eq 'oboobs') {
if (defined $args) {
if ($args == 1) {

103
lib/BotLib/Admin.pm
View File

@@ -18,7 +18,7 @@ use Exporter qw (import);
our @ISA = qw / Exporter /; ## no critic (ClassHierarchies::ProhibitExplicitISA)
our @EXPORT_OK = qw (@ForbiddenMessageTypes @PluginList GetForbiddenTypes AddForbiddenType DelForbiddenType
ListForbidden FortuneToggle FortuneToggleList FortuneStatus PluginToggle PluginStatus
PluginEnabled);
PluginEnabled ChanMsgToggle ChanMsgStatus ChanMsgEnabled);
my $c = LoadConf ();
my $cachedir = $c->{cachedir};
@@ -176,6 +176,107 @@ sub FortuneToggleList () {
return $cache->get_keys ();
}
sub ChanMsgToggle (@) {
my $chatid = shift;
my $action = shift // undef;
my $phrase = 'Сообщения, пришедшие от имени каналов ';
my $cache = CHI->new (
driver => 'BerkeleyDB',
root_dir => $cachedir,
namespace => __PACKAGE__ . '_' . 'chan_msg'
);
my $state = $cache->get ($chatid);
if (defined $action) {
if ($action) {
$cache->set ($chatid, 1, 'never');
$phrase .= 'не будут удаляться.';
} else {
if (defined $state && $state) {
$cache->set ($chatid, 0, 'never');
$phrase .= 'будут удаляться.';
} else {
$cache->set ($chatid, 1, 'never');
$phrase .= 'не будут удаляться.';
}
}
} else {
if (defined $state){
if ($state) {
$cache->set ($chatid, 0, 'never');
$phrase .= 'будут удаляться.';
} else {
$cache->set ($chatid, 1, 'never');
$phrase .= 'не будут удаляться.';
}
} else {
$cache->set ($chatid, 1, 'never');
$phrase .= 'не будут удаляться.';
}
}
return $phrase;
}
sub ChanMsgStatus ($) {
my $chatid = shift;
my $phrase = 'Сообщения, пришедшие от имени каналов ';
my $cache = CHI->new (
driver => 'BerkeleyDB',
root_dir => $cachedir,
namespace => __PACKAGE__ . '_' . 'chan_msg'
);
my $state = $cache->get ($chatid);
if (defined $state) {
if ($state) {
$phrase .= 'не удаляются.';
} else {
$phrase .= 'удаляются.';
}
} else {
$phrase .= 'не удаляются.';
}
return $phrase;
}
sub ChanMsgEnabled ($) {
my $chatid = shift;
my $cache = CHI->new (
driver => 'BerkeleyDB',
root_dir => $cachedir,
namespace => __PACKAGE__ . '_' . 'chan_msg'
);
my $state = $cache->get ($chatid);
if (defined $state) {
if ($state) {
return 1;
} else {
return 0;
}
} else {
return 1;
}
}
sub ChanMsgToggleList () {
my $cache = CHI->new (
driver => 'BerkeleyDB',
root_dir => $cachedir,
namespace => __PACKAGE__ . '_' . 'chan_msg'
);
return $cache->get_keys ();
}
sub PluginStatus (@) {
my $chatid = shift;
my $plugin = shift;

88
lib/BotLib/Anek.pm
View File

@@ -1,88 +0,0 @@
package BotLib::Anek;
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Encode;
use HTML::TokeParser;
use JSON::XS;
use Log::Any qw ($log);
use Mojo::UserAgent;
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (Anek);
sub Anek {
my $r;
my $ret = 'Все рассказчики анекдотов отдыхают';
my $got_anek = 0;
for (1..3) {
for (1..3) {
my $ua = Mojo::UserAgent->new->connect_timeout (3);
$ua->max_redirects(3);
$r = $ua->get ('https://www.anekdot.ru/rss/randomu.html')->result;
if ($r->is_success) {
last;
}
sleep 2;
}
if ($r->is_success) {
my $json;
my $response_text = decode ('UTF-8', $r->body);
my @text = split /\n/, $response_text;
while (my $str = pop @text) {
if ($str =~ /^var anekdot_texts \= JSON/) {
$str = (split /JSON\.parse\(\'/, $str, 2)[1];
if (defined $str && length ($str) > 10) {
$json = (split /\';\)/, $str, 2)[0];
last;
}
}
}
if (defined $json && length ($json) > 10) {
$json =~ s/\\"/"/g;
$json =~ s/\\\\"/\\"/g;
$json = substr $json, 0, -3;
my $anek = eval { ${JSON::XS->new->relaxed->decode ($json)}[0] };
if (defined $anek) {
my @anek = split /<br>/, $anek;
$ret = join "\n", @anek;
if (length ($ret) > 1) {
$got_anek = 1;
}
} else {
$log->warn (sprintf '[WARN] anekdot.ru server returns incorrect json, full response text message: %s', $response_text);
}
} else {
$log->warn (sprintf '[WARN] anekdot.ru server returns unexpected response text: %s', $r->body);
}
} else {
$log->warn (sprintf '[WARN] anekdot.ru server return status %s with message: %s', $r->code, $r->message);
}
if ($got_anek) {
last;
}
}
return $ret;
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

60
lib/BotLib/Buni.pm
View File

@@ -1,60 +0,0 @@
package BotLib::Buni;
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 HTML::TokeParser;
use Log::Any qw ($log);
use Mojo::UserAgent;
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (Buni);
sub Buni {
my $r;
my $ret = 'Нету Buni';
for (1..3) {
my $ua = Mojo::UserAgent->new->connect_timeout (3);
$ua->max_redirects(3);
$r = $ua->get ('http://www.bunicomic.com/?random&nocache=1')->result;
if ($r->is_success) {
last;
}
sleep 2;
}
if ($r->is_success) {
my $p = HTML::TokeParser->new(\$r->body);
my @a;
# additional {} required in order "last" to work properly :)
{
do {
$#a = -1;
@a = $p->get_tag('meta'); ## no critic (Variables::RequireLocalizedPunctuationVars)
if (defined $a[0][1]->{property} && $a[0][1]->{property} eq 'og:image') {
$ret = sprintf '[buni](%s)', $a[0][1]->{content};
last;
}
} while ($#{$a[0]} > 1);
}
} else {
$log->warn (sprintf '[WARN] Bunicomic server return status %s with message: %s', $r->code, $r->message);
}
return $ret;
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

115
lib/BotLib/Drink.pm
View File

@@ -1,115 +0,0 @@
package BotLib::Drink;
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use CHI;
use CHI::Driver::BerkeleyDB;
use DateTime;
use English qw ( -no_match_vars );
use Encode;
use Carp qw (cluck);
use HTML::TokeParser;
use Log::Any qw ($log);
use Mojo::Log;
use Mojo::UserAgent::Cached;
use POSIX qw (strftime);
use BotLib::Conf qw (LoadConf);
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (Drink);
my @MONTH = qw (yanvar fevral mart aprel may iyun iyul avgust sentyabr oktyabr noyabr dekabr);
my $c = LoadConf ();
my $cachedir = $c->{cachedir};
sub Drink {
my $r;
my $ret = 'Не знаю праздников - вджобываю весь день на шахтах, как проклятая.';
my ($dayNum, $monthNum) = (localtime ())[3, 4];
my $url = sprintf 'https://kakoysegodnyaprazdnik.ru/baza/%s/%s', $MONTH[$monthNum], $dayNum;
# Those POSIX assholes just forgot to add unix timestamps without TZ offset, so...
my ($mday, $mon, $year) = (gmtime ())[3, 4, 5];
my $offset = strftime ('%z', gmtime ());
my $offsetMinutes = (substr $offset, -2) * 60;
my $offsetHours = (substr $offset, 1, 2) * 60 * 60;
my $offsetSign;
if ((substr $offset, 0, 1) eq '+') {
$offsetSign = 1;
}
my $expirationDate = DateTime->new (
year => $year + 1900,
month => $mon + 1,
day => $mday,
hour => 0,
minute => 0,
second => 0
)->add (days => 1)->strftime ('%s');
if ((substr $offset, 0, 1) eq '+') {
$expirationDate = $expirationDate - $offsetHours - $offsetMinutes;
} else {
$expirationDate = $expirationDate + $offsetHours + $offsetMinutes;
}
for (1..3) {
my $ua = Mojo::UserAgent::Cached->new->connect_timeout (3);
$ua->cache_agent(
CHI->new (
driver => 'BerkeleyDB',
root_dir => $cachedir,
namespace => __PACKAGE__,
expires_at => $expirationDate,
expires_on_backend => 1,
)
);
# just to make Mojo::UserAgent::Cached happy
$ua->logger (Mojo::Log->new (path => '/dev/null', level => 'error'));
$r = $ua->get ($url => {'Accept-Language' => 'ru-RU', 'Accept-Charset' => 'utf-8'})->result;
if ($r->is_success) {
last;
}
sleep 2;
}
if ($r->is_success) {
my $p = HTML::TokeParser->new(\$r->body);
my @a;
my @holyday;
do {
$#a = -1;
@a = $p->get_tag('span'); ## no critic (Variables::RequireLocalizedPunctuationVars)
if ($#{$a[0]} > 2 && defined $a[0][1]->{itemprop} && $a[0][1]->{itemprop} eq 'text') {
push @holyday,'* ' . decode ('UTF-8', $p->get_trimmed_text ('/span'));
}
} while ($#{$a[0]} > 1);
if ($#holyday > 0) {
# cut off something weird, definely not a "holyday"
$#holyday = $#holyday - 1;
}
if ($#holyday > 0) {
$ret = join "\n", @holyday;
}
} else {
$log->warn (sprintf '[WARN] Kakoysegodnyaprazdnik server return status %s with message: %s', $r->code, $r->message);
}
return $ret;
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

86
lib/BotLib/Fortune.pm
View File

@@ -1,86 +0,0 @@
package BotLib::Fortune;
# Any fortune_mod sources are suitable. Text file with "\n%\n" sentence delimeter.
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Carp qw (cluck croak);
use File::Path qw (make_path);
use Log::Any qw ($log);
use Math::Random::Secure qw (irand);
use SQLite_File;
use BotLib::Conf qw (LoadConf);
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (Seed Fortune);
my $c = LoadConf ();
my $dir = $c->{fortune}->{dir};
my $srcdir = $c->{fortune}->{srcdir};
sub Seed () {
unless (-d $dir) {
make_path ($dir) || croak "Unable to create $dir: $OS_ERROR";
}
my $backingfile = sprintf '%s/fortune.sqlite', $dir;
if (-f $backingfile) {
unlink $backingfile || croak "Unable to remove $backingfile: $OS_ERROR";
}
tie my @fortune, 'SQLite_File', $backingfile || croak "Unable to tie to $backingfile: $OS_ERROR";
opendir (my $srcdirhandle, $srcdir) || croak "Unable to open $srcdir: $OS_ERROR";
while (my $fortunefile = readdir ($srcdirhandle)) {
my $srcfile = sprintf '%s/%s', $srcdir, $fortunefile;
unless (-f $srcfile) {
next;
}
if ($fortunefile =~ m/^\.+$/) {
next;
}
open (my $fh, '<', $srcfile) || croak "Unable to open $srcfile, $OS_ERROR";
# set correct phrase delimiter
local $INPUT_RECORD_SEPARATOR = "\n%\n";
while (readline $fh) {
my $phrase = substr $_, 0, -3;
push @fortune, $phrase;
}
close $fh; ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
}
closedir $srcdirhandle;
untie @fortune;
return;
}
# just return answer
sub Fortune () {
my $backingfile = sprintf '%s/fortune.sqlite', $dir;
tie my @array, 'SQLite_File', $backingfile || do {
$log->error ("[ERROR] Unable to tie to $backingfile: $OS_ERROR");
return '';
};
my $phrase = $array[irand ($#array + 1)];
# decode?
utf8::decode $phrase;
untie @array;
return $phrase;
}
1;
# vim: ft=perl noet ai ts=4 sw=4 sts=4:

96
lib/BotLib/Friday.pm
View File

@@ -1,96 +0,0 @@
package BotLib::Friday;
# for friday data stolen from https://raw.githubusercontent.com/isida/vi/master/data/friday.txt
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Carp qw (cluck croak);
use File::Path qw (make_path);
use Log::Any qw ($log);
use Math::Random::Secure qw (irand);
use SQLite_File;
use BotLib::Conf qw (LoadConf);
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (Seed Friday);
my $c = LoadConf ();
my $dir = $c->{friday}->{dir};
my $srcfile = $c->{friday}->{src};
my @dow = qw (monday tuesday wednesday thursday friday saturday sunday);
sub Seed () {
unless (-d $dir) {
make_path ($dir) || croak "Unable to create $dir: $OS_ERROR";
}
my $friday;
for (0..$#dow) {
my $backingfile = sprintf '%s/%s.sqlite', $dir, $dow[$_];
if (-f $backingfile) {
unlink $backingfile || croak "Unable to remove $backingfile: $OS_ERROR\n";
}
tie @{$friday->[$_]}, 'SQLite_File', $backingfile || croak "Unable to tie to $backingfile: $OS_ERROR\n";
}
open (my $fh, '<', $srcfile) || croak "Unable to open $srcfile, $OS_ERROR\n";
while (readline $fh) {
unless (m/ \|\| /xmsg) {
next;
}
chomp();
my ($phrase, $days) = split(/ \|\| /);
my @daylist = split(//, $days);
foreach my $day (@daylist) {
unless (defined $day) {
next;
}
unless ($day =~ /^\d$/) {
next;
}
if (defined $phrase && ($phrase ne '') && ($phrase !~ m/^\s+$/xmsg)) {
push @{$friday->[$day - 1]}, $phrase;
}
}
}
close $fh; ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
for (0..$#dow) {
untie $friday->[$_];
}
return;
}
# just return answer
sub Friday () {
my $today = (localtime (time))[6] - 1;
my $backingfile = sprintf '%s/%s.sqlite', $dir, $dow[$today];
tie my @array, 'SQLite_File', $backingfile || do {
$log->error ("[ERROR] Unable to tie to $backingfile: $OS_ERROR\n");
return '';
};
my $phrase = $array[irand ($#array + 1)];
utf8::decode $phrase;
untie @array;
return $phrase;
}
1;
# vim: ft=perl noet ai ts=4 sw=4 sts=4:

241
lib/BotLib/Image.pm
View File

@@ -1,241 +0,0 @@
package BotLib::Image;
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 Log::Any qw ($log);
use Math::Random::Secure qw (irand);
use Mojo::UserAgent;
use BotLib::Image::Flickr qw (FlickrByTags);
use BotLib::Image::Imgur qw (Imgur);
use BotLib::Util qw (urlencode);
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (Kitty Fox Oboobs Obutts Rabbit Owl Frog Horse Snail);
sub Kitty {
my $r;
my $ret = 'Нету кошечек, все разбежались.';
for (1..3) {
my $ua = Mojo::UserAgent->new->connect_timeout (3);
$r = $ua->get ('https://api.thecatapi.com/v1/images/search')->result;
if ($r->is_success) {
last;
}
sleep 2;
}
if ($r->is_success) {
my $jcat = eval {
return $r->json;
};
unless (defined $jcat) {
$log->warn ("[WARN] Unable to decode JSON from thecatapi: $EVAL_ERROR");
} else {
if ($jcat->[0]->{url}) {
my @cats = ('龴ↀ◡ↀ龴', '=^..^=', '≧◔◡◔≦ ','^ↀᴥↀ^');
$ret = sprintf '[%s](%s)', $cats[irand ($#cats + 1)], $jcat->[0]->{url};
}
}
} else {
$log->warn (sprintf '[WARN] Thecatapi server return status %s with message: %s', $r->code, $r->message);
}
return $ret;
}
sub Fox {
my $r;
my $ret = 'Нету лисичек, все разбежались.';
for (1..3) {
my $ua = Mojo::UserAgent->new->connect_timeout (3);
$r = $ua->get ('https://randomfox.ca/floof/')->result;
if ($r->is_success) {
last;
}
sleep 2;
}
if ($r->is_success) {
my $jfox = eval {
return $r->json;
};
unless (defined $jfox) {
$log->warn ("[WARN] Unable to decode JSON from randomfox: $EVAL_ERROR");
} else {
if ($jfox->{image}) {
$jfox->{image} =~ s/\\//xmsg;
$ret = sprintf '[-^^,--,~](%s)', $jfox->{image};
}
}
} else {
$log->warn (sprintf '[WARN] Randomfox server return status %s with message: %s', $r->code, $r->message);
}
return $ret;
}
sub Oboobs {
my $r;
my $ret = 'Нету cисичек, все разбежались.';
for (1..3) {
my $ua = Mojo::UserAgent->new->connect_timeout (3);
$r = $ua->get ('http://api.oboobs.ru/boobs/0/1/random')->result;
if ($r->is_success) {
last;
}
sleep 2;
}
if ($r->is_success) {
my $joboobs = eval {
return $r->json;
};
unless (defined $joboobs) {
$log->warn ("[WARN] Unable to decode JSON from oboobs: $EVAL_ERROR");
} else {
if ($joboobs->[0]->{preview}) {
my @boobs = ('(. )( .)', '( . Y . )', '(o)(o)', '( @ )( @ )', '(.)(.)');
$ret = sprintf '[%s](https://media.oboobs.ru/%s)', $boobs[irand ($#boobs + 1)], $joboobs->[0]->{preview};
}
}
} else {
$log->warn (sprintf '[WARN] Oboobs server return status %s with message: %s', $r->code, $r->message);
}
return $ret;
}
sub Obutts {
my $r;
my $ret = 'Нету попок, все разбежались.';
for (1..3) {
my $ua = Mojo::UserAgent->new->connect_timeout (3);
$r = $ua->get ('http://api.obutts.ru/butts/0/1/random')->result;
if ($r->is_success) {
last;
}
sleep 2;
}
if ($r->is_success) {
my $jobutts = eval {
return $r->json;
};
unless (defined $jobutts) {
$log->warn ("[ERROR] Unable to decode JSON from obutts: $EVAL_ERROR");
} else {
if ($jobutts->[0]->{preview}) {
my @butts = ('(__(__)', '(_!_)', '(__.__)');
$ret = sprintf '[%s](http://media.obutts.ru/%s)', $butts[irand ($#butts + 1)], $jobutts->[0]->{preview};
}
}
} else {
$log->warn (sprintf '[WARN] Obutts server return status %s with message: %s', $r->code, $r->message);
}
return $ret;
}
# It works but results are not particularly relevant, partially. about 20-30% miss
# So i prefer to use flickr rabbits selection :)
sub rabbit_imgur {
my @terms = (
urlencode '?q=animals AND (rabbits OR bunnies)',
urlencode 'year?q=animals AND (rabbits OR bunnies)',
urlencode 'relevance?q=animals AND (rabbits OR bunnies)',
urlencode 'relevance/year?q=animals AND (rabbits OR bunnies)',
urlencode 'score?q_not=cat OR kitten OR kittens OR dog OR cats OR dogs OR puppy OR puppies&q_tags=bunnies,bunny,rabbits,rabbit',
);
my $rabbit = Imgur ($terms[irand ($#terms + 1)]);
# return just large thumbnail instead of real photo (that can be really huge)
$rabbit = sprintf '%sl%s', substr ($rabbit, 0, -4), substr ($rabbit, -4);
if (defined $rabbit) {
return sprintf '[(\_/)](%s)', $rabbit;
} else {
return 'Нету кроликов, все разбежались.'
}
}
sub Rabbit {
# rabbit, but bunny
my $url = FlickrByTags ('animal,bunny');
if (defined $url) {
return sprintf '[(\_/)](%s)', $url;
} else {
return 'Нету кроликов, все разбежались.';
}
}
sub Owl {
my $url = FlickrByTags ('bird,owl');
if (defined $url) {
return sprintf '[{ O v O }](%s)', $url;
} else {
return 'Нету сов, все разлетелись.';
}
}
sub Frog {
# unable to find any one-line ascii art for frog :(
my @art = qw (frog toad лягушка);
my $url = FlickrByTags ('frog,toad,amphibian');
if (defined $url) {
return sprintf '[%s](%s)', $art [irand ($#art + 1)], $url;
} else {
return 'Нету лягушек, все свалили.';
}
}
sub Horse {
# unable to find any one-line ascii art for frog :(
my @art = qw (horse лошадь лошадка);
my $url = FlickrByTags ('horse,equine,mammal');
if (defined $url) {
return sprintf '[%s](%s)', $art [irand ($#art + 1)], $url;
} else {
return 'Нету коняшек, все разбежались.';
}
}
sub Snail {
# unable to find any one-line ascii art for frog :(
my @art = qw ('-'_@_ @╜ @_'-');
my $url = FlickrByTags ('snail,slug');
if (defined $url) {
return sprintf '[%s](%s)', $art [irand ($#art + 1)], $url;
} else {
return 'Нету улиток, все расползлись.';
}
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

599
lib/BotLib/Image/Flickr.pm
View File

@@ -1,599 +0,0 @@
package BotLib::Image::Flickr;
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 Digest::HMAC_SHA1 qw (hmac_sha1);
use Log::Any qw ($log);
use Math::Random::Secure qw (irand);
use MIME::Base64;
use Mojo::UserAgent;
use URI::Encode::XS qw (uri_encode);
use BotLib::Conf qw (LoadConf);
use BotLib::Util qw (urlencode);
use Data::Dumper;
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (FlickrInit FlickrByTags FlickrByText FlickrTestLogin);
my $c = LoadConf ();
my $cachedir = $c->{cachedir};
my $flickr_consumer_key = $c->{image}->{flickr}->{consumer_key};
my $flickr_consumer_secret = $c->{image}->{flickr}->{consumer_secret};
my $flickr_verifier = $c->{image}->{flickr}->{verifier};
my $flickr_request_token_url = 'https://www.flickr.com/services/oauth/request_token';
my $flickr_authorization_url = 'https://www.flickr.com/services/oauth/authorize';
my $flickr_access_token_url = 'https://www.flickr.com/services/oauth/access_token';
my $flickr_callback_url = 'http://www.example.com';
my $flickr_api_url = 'https://www.flickr.com/services/rest/';
sub mknonce {
# make random number, 8 symbols in length
my $nonce = sprintf '%08d', irand (99999999);
return $nonce;
}
sub flickerSignReq {
my %p = @_;
my $string;
my $hmac;
if ($p{type} eq 'request_token') {
my @parameters;
delete $p{type};
push @parameters, 'oauth_signature_method=HMAC-SHA1';
push @parameters, 'oauth_version=1.0';
push @parameters, sprintf 'oauth_callback=%s', uri_encode ($flickr_callback_url);
push @parameters, sprintf 'oauth_consumer_key=%s', $flickr_consumer_key;
foreach my $param (keys %p) {
push @parameters, sprintf ('%s=%s', $param, $p{$param});
}
$string = sprintf 'GET&%s&', uri_encode ($flickr_request_token_url);
$string .= uri_encode (join '&', sort (@parameters));
# Thanks to twitter api dev portal, they explain this particular case: while we requesting this token
# we do not yet know access_token secret, so we just omit it in this signature
# https://developer.twitter.com/en/docs/authentication/oauth-1-0a/creating-a-signature
$hmac = Digest::HMAC_SHA1->new (sprintf '%s&', uri_encode ($flickr_consumer_secret));
} elsif ($p{type} eq 'access_token') {
my @parameters;
my $flickr_request_token_secret = $p{oauth_token_secret};
delete $p{oauth_token_secret};
delete $p{type};
push @parameters, 'oauth_signature_method=HMAC-SHA1';
push @parameters, 'oauth_version=1.0';
push @parameters, sprintf 'oauth_consumer_key=%s', $flickr_consumer_key;
foreach my $param (keys %p) {
push @parameters, sprintf ('%s=%s', $param, $p{$param});
}
$string = sprintf 'GET&%s&', uri_encode ($flickr_access_token_url);
$string .= uri_encode (join '&', sort (@parameters));
$hmac = Digest::HMAC_SHA1->new (sprintf '%s&%s', uri_encode ($flickr_consumer_secret), uri_encode ($flickr_request_token_secret));
} elsif ($p{type} eq 'test_login' || $p{type} eq 'search_text' || $p{type} eq 'search_tags') {
my @parameters;
my $flickr_request_token_secret = $p{oauth_token_secret};
delete $p{oauth_token_secret};
delete $p{type};
foreach my $param (keys %p) {
push @parameters, sprintf ('%s=%s', $param, $p{$param});
}
$string = sprintf 'GET&%s&', uri_encode ($flickr_api_url);
$string .= uri_encode (join '&', sort (@parameters));
$hmac = Digest::HMAC_SHA1->new (sprintf '%s&%s', uri_encode ($flickr_consumer_secret), uri_encode ($flickr_request_token_secret));
}
$hmac->add ($string);
return encode_base64 ($hmac->digest, '');
}
sub flickrRequestToken {
my $oauth_timestamp = time ();
my $oauth_nonce = mknonce ();
my $oauth_signature = flickerSignReq (
type => 'request_token',
oauth_timestamp => $oauth_timestamp,
oauth_nonce => $oauth_nonce
);
my $url = $flickr_request_token_url . sprintf (
'?oauth_nonce=%s&oauth_timestamp=%s&oauth_consumer_key=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&&oauth_signature=%s&oauth_callback=%s',
$oauth_nonce,
$oauth_timestamp,
$flickr_consumer_key,
uri_encode ($oauth_signature),
uri_encode ($flickr_callback_url)
);
my $ua = Mojo::UserAgent->new->connect_timeout (5);
my $r = $ua->get ($url)->result;
my %params;
if ($r->is_success) {
# they ignore format=json, so...
%params = map {split /=/} split /&/, $r->body;
} else {
say "Something bad returns from flickr api: $r->code $r->message"; ## no critic (InputOutput::RequireCheckedSyscalls)
}
return %params;
}
sub flickrAccessToken {
my $flickr_request_token = shift;
my $flickr_request_token_secret = shift;
my $flickr_verifier = shift; ## no critic (Variables::ProhibitReusedNames)
my $oauth_timestamp = time ();
my $oauth_nonce = mknonce ();
my $oauth_signature = flickerSignReq (
type => 'access_token',
oauth_timestamp => $oauth_timestamp,
oauth_nonce => $oauth_nonce,
oauth_token => $flickr_request_token,
oauth_token_secret => $flickr_request_token_secret,
oauth_verifier => $flickr_verifier
);
my $url = $flickr_access_token_url . sprintf (
'?oauth_nonce=%s&oauth_timestamp=%s&oauth_verifier=%s&oauth_consumer_key=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s',
$oauth_nonce,
$oauth_timestamp,
$flickr_verifier,
$flickr_consumer_key,
$flickr_request_token,
uri_encode ($oauth_signature)
);
my $ua = Mojo::UserAgent->new->connect_timeout (5);
my $r = $ua->get ($url)->result;
my %params;
if ($r->is_success) {
# they ignore format=json
%params = map {split /=/} split /&/, $r->body;
} else {
say "Something bad returns from flickr api: $r->code $r->message"; ## no critic (InputOutput::RequireCheckedSyscalls)
}
return %params;
}
sub flickrAuthorization {
my $flickr_request_token = shift;
my $url = $flickr_authorization_url . sprintf (
'?oauth_token=%s&perms=read',
$flickr_request_token,
);
my $ua = Mojo::UserAgent->new->connect_timeout (5);
my $r = $ua->get ($url)->result;
if ($r->code == 302) {
return $r->content->headers->location;
} else {
printf "Something went wrong: %s %s\n", $r->code, $r->message;
return;
}
}
sub flickrTestLogin {
my $flickr_access_token = shift;
my $flickr_access_token_secret = shift;
my $oauth_timestamp = time ();
my $oauth_nonce = mknonce ();
my $oauth_signature = flickerSignReq (
nojsoncallback => 1,
oauth_nonce => $oauth_nonce,
format => 'json',
oauth_consumer_key => $flickr_consumer_key,
oauth_timestamp => $oauth_timestamp,
type => 'test_login',
method => 'flickr.test.login',
oauth_token => $flickr_access_token,
oauth_token_secret => $flickr_access_token_secret,
oauth_signature_method => 'HMAC-SHA1',
oauth_version => '1.0'
);
my $url = $flickr_api_url . sprintf (
'?nojsoncallback=1&oauth_nonce=%s&format=json&oauth_consumer_key=%s&oauth_timestamp=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s&method=flickr.test.login',
$oauth_nonce,
$flickr_consumer_key,
$oauth_timestamp,
$flickr_access_token,
uri_encode ($oauth_signature)
);
my $ua = Mojo::UserAgent->new->connect_timeout (5);
my $r = $ua->get ($url)->result;
if ($r->is_success) {
my $response = eval {
return $r->json;
};
if (defined $response) {
say Dumper $response; ## no critic (InputOutput::RequireCheckedSyscalls)
return 1;
} else {
say "Flickr api returns incorrect json: $r->message"; ## no critic (InputOutput::RequireCheckedSyscalls)
return 0;
}
} else {
say "HTTP status code not 200: $r->code, $r->message"; ## no critic (InputOutput::RequireCheckedSyscalls)
return 0;
}
}
sub flickrSearchByText {
my $flickr_access_token = shift;
my $flickr_access_token_secret = shift;
my $text = shift;
my $oauth_timestamp = time ();
my $oauth_nonce = mknonce ();
my $oauth_signature = flickerSignReq (
nojsoncallback => 1,
oauth_nonce => $oauth_nonce,
format => 'json',
oauth_consumer_key => $flickr_consumer_key,
oauth_timestamp => $oauth_timestamp,
type => 'search_text',
content_type => 1,
media => 'photos',
method => 'flickr.photos.search',
text => $text,
per_page => 1,
oauth_token => $flickr_access_token,
oauth_token_secret => $flickr_access_token_secret,
oauth_signature_method => 'HMAC-SHA1',
oauth_version => '1.0'
);
my $url = $flickr_api_url . sprintf (
'?nojsoncallback=1&oauth_nonce=%s&format=json&oauth_consumer_key=%s&oauth_timestamp=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s&method=flickr.photos.search&content_type=1&media=photos&per_page=1&text=%s',
$oauth_nonce,
$flickr_consumer_key,
$oauth_timestamp,
$flickr_access_token,
uri_encode ($oauth_signature),
uri_encode ($text)
);
my $ua = Mojo::UserAgent->new->connect_timeout (5);
my $r = $ua->get ($url)->result;
if ($r->is_success) {
my $response = eval {
return $r->json;
};
if (defined $response) {
# lets make another query, this time with random picture
my $page = irand int ($response->{photos}->{total} / 500);
$oauth_timestamp = time ();
$oauth_nonce = mknonce ();
$oauth_signature = flickerSignReq (
nojsoncallback => 1,
oauth_nonce => $oauth_nonce,
format => 'json',
oauth_consumer_key => $flickr_consumer_key,
oauth_timestamp => $oauth_timestamp,
type => 'search_text',
content_type => 1,
media => 'photos',
method => 'flickr.photos.search',
text => $text,
page => $page,
per_page => 500,
oauth_token => $flickr_access_token,
oauth_token_secret => $flickr_access_token_secret,
oauth_signature_method => 'HMAC-SHA1',
oauth_version => '1.0'
);
$url = $flickr_api_url . sprintf (
'?nojsoncallback=1&oauth_nonce=%s&format=json&oauth_consumer_key=%s&oauth_timestamp=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s&method=flickr.photos.search&content_type=1&media=photos&per_page=500&page=%d&text=%s',
$oauth_nonce,
$flickr_consumer_key,
$oauth_timestamp,
$flickr_access_token,
uri_encode ($oauth_signature),
$page,
uri_encode ($text)
);
$ua = Mojo::UserAgent->new->connect_timeout (5);
$r = $ua->get ($url)->result;
if ($r->is_success) {
$response = eval {
return $r->json;
};
if (defined $response) {
return $response;
} else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
return undef;
}
} else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
return undef;
}
} else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
return undef;
}
} else {
$log->warn ("[WARN] Flickr api HTTP status code not 200: $r->code, $r->message");
return undef;
}
}
sub flickrSearchByTags {
my $flickr_access_token = shift;
my $flickr_access_token_secret = shift;
my $tags = shift;
my $oauth_timestamp = time ();
my $oauth_nonce = mknonce ();
my $oauth_signature = flickerSignReq (
nojsoncallback => 1,
oauth_nonce => $oauth_nonce,
format => 'json',
oauth_consumer_key => $flickr_consumer_key,
oauth_timestamp => $oauth_timestamp,
type => 'search_tags',
content_type => 1,
media => 'photos',
method => 'flickr.photos.search',
tags => $tags,
per_page => 1,
oauth_token => $flickr_access_token,
oauth_token_secret => $flickr_access_token_secret,
oauth_signature_method => 'HMAC-SHA1',
oauth_version => '1.0'
);
my $url = $flickr_api_url . sprintf (
'?nojsoncallback=1&oauth_nonce=%s&format=json&oauth_consumer_key=%s&oauth_timestamp=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s&method=flickr.photos.search&content_type=1&media=photos&per_page=1&tags=%s&tag_mode=all',
$oauth_nonce,
$flickr_consumer_key,
$oauth_timestamp,
$flickr_access_token,
uri_encode ($oauth_signature),
uri_encode ($tags)
);
my $ua = Mojo::UserAgent->new->connect_timeout (5);
my $r = $ua->get ($url)->result;
if ($r->is_success) {
my $response = eval {
return $r->json;
};
if (defined $response) {
# lets make another query, this time with random picture
my $page = irand int ($response->{photos}->{total} / 500);
$oauth_timestamp = time ();
$oauth_nonce = mknonce ();
$oauth_signature = flickerSignReq (
nojsoncallback => 1,
oauth_nonce => $oauth_nonce,
format => 'json',
oauth_consumer_key => $flickr_consumer_key,
oauth_timestamp => $oauth_timestamp,
type => 'search_text',
content_type => 1,
media => 'photos',
method => 'flickr.photos.search',
tags => $tags,
page => $page,
per_page => 500,
oauth_token => $flickr_access_token,
oauth_token_secret => $flickr_access_token_secret,
oauth_signature_method => 'HMAC-SHA1',
oauth_version => '1.0'
);
$url = $flickr_api_url . sprintf (
'?nojsoncallback=1&oauth_nonce=%s&format=json&oauth_consumer_key=%s&oauth_timestamp=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s&method=flickr.photos.search&content_type=1&media=photos&per_page=500&page=%d&tags=%s&tag_mode=all',
$oauth_nonce,
$flickr_consumer_key,
$oauth_timestamp,
$flickr_access_token,
uri_encode ($oauth_signature),
$page,
uri_encode ($tags)
);
$ua = Mojo::UserAgent->new->connect_timeout (5);
$r = $ua->get ($url)->result;
if ($r->is_success) {
$response = eval {
return $r->json;
};
if (defined $response) {
return $response;
} else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
return undef;
}
} else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
return undef;
}
} else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
return undef;
}
} else {
$log->warn ("[WARN] Flickr api HTTP status code not 200: $r->code, $r->message");
return undef;
}
}
sub FlickrInit {
my $cache = CHI->new (
driver => 'BerkeleyDB',
root_dir => $cachedir,
namespace => __PACKAGE__
);
if (defined $flickr_verifier && $flickr_verifier) {
my $flickr_request_token = $cache->get ('flickr_request_token');
my $flickr_request_token_secret = $cache->get ('flickr_request_token_secret');
unless (defined $flickr_request_token || defined $flickr_request_token_secret) {
say 'Looks like there is no request token or request token secret in config db.'; ## no critic (InputOutput::RequireCheckedSyscalls)
say 'Please remove verifier settings from config.json and run this script again.'; ## no critic (InputOutput::RequireCheckedSyscalls)
return 0;
}
my %accessToken = flickrAccessToken ($flickr_request_token, $flickr_request_token_secret, $flickr_verifier);
if (defined ($accessToken{oauth_token}) && defined ($accessToken{oauth_token_secret})) {
# TODO: check set
$cache->set ('flickr_access_token', $accessToken{oauth_token}, 'never');
$cache->set ('flickr_access_token_secret', $accessToken{oauth_token_secret}, 'never');
say sprintf ( ## no critic (InputOutput::RequireCheckedSyscalls)
'Access token (%s) and access token secret (%s) are config db',
$accessToken{oauth_token},
$accessToken{oauth_token_secret},
);
return 1;
}
} else {
my %req = flickrRequestToken ();
if (defined ($req{oauth_token}) && defined ($req{oauth_token_secret}) && defined ($req{oauth_token})) {
# TODO: check set
$cache->set ('flickr_request_token', $req{oauth_token}, 'never');
$cache->set ('flickr_request_token_secret', $req{oauth_token_secret}, 'never');
my $confirm_url = flickrAuthorization ($req{oauth_token});
if (defined $confirm_url) {
say "Please open this url in your browser and grant access for this app:\n$confirm_url"; ## no critic (InputOutput::RequireCheckedSyscalls)
say 'Do not forget to put oauth_verifier to config.json file and re-run this script to get access token'; ## no critic (InputOutput::RequireCheckedSyscalls)
say 'Note that you should be logged off from flickr account.'; ## no critic (InputOutput::RequireCheckedSyscalls)
return 1;
}
}
}
return 0;
}
sub FlickrTestLogin {
my $text = shift;
my $cache = CHI->new (
driver => 'BerkeleyDB',
root_dir => $cachedir,
namespace => __PACKAGE__
);
my $flickr_access_token = $cache->get ('flickr_access_token');
my $flickr_access_token_secret = $cache->get ('flickr_access_token_secret');
if (flickrTestLogin ($flickr_access_token, $flickr_access_token_secret)) {
return 1;
} else {
return 0;
}
}
sub FlickrByTags {
my $text = shift;
my $cache = CHI->new (
driver => 'BerkeleyDB',
root_dir => $cachedir,
namespace => __PACKAGE__
);
my $flickr_access_token = $cache->get ('flickr_access_token');
my $flickr_access_token_secret = $cache->get ('flickr_access_token_secret');
# NB: I honestly query random page (among number of pages) of results from api, but always got first page,
# no matter what is shown in response' "page" parameter. Looks like bug in API. Try to little bit mitigate
# this bug via query 500 results per page, then we can select random result in this heap. But anyway, let's
# make this thing future proof and leave randomizer in page select.
my $result = flickrSearchByTags ($flickr_access_token, $flickr_access_token_secret, $text);
if ($result) {
if (defined ($result->{photos}) && defined ($result->{photos}->{photo})) {
my $item = irand int(@{$result->{photos}->{photo}});
$item = ${$result->{photos}->{photo}}[$item];
$item = sprintf 'https://live.staticflickr.com/%s/%s_%s_z.jpg', $item->{server}, $item->{id}, $item->{secret};
return $item;
} else {
$log->notice ('[NOTICE] Flickr api returns empty search result list');
return;
}
} else {
return;
}
}
sub FlickrByText {
my $text = shift;
my $cache = CHI->new (
driver => 'BerkeleyDB',
root_dir => $cachedir,
namespace => __PACKAGE__
);
my $flickr_access_token = $cache->get ('flickr_access_token');
my $flickr_access_token_secret = $cache->get ('flickr_access_token_secret');
# NB: I honestly query random page (among number of pages) of results from api, but always got first page,
# no matter what is shown in response' "page" parameter. Looks like bug in API. Try to little bit mitigate
# this bug via query 500 results per page, then we can select random result in this heap. But anyway, let's
# make this thing future proof and leave randomizer in page select.
my $result = flickrSearchByText ($flickr_access_token, $flickr_access_token_secret, $text);
if ($result) {
if (defined ($result->{photos}) && defined ($result->{photos}->{photo})) {
my $item = irand int(@{$result->{photos}->{photo}});
$item = ${$result->{photos}->{photo}}[$item];
$item = sprintf 'https://live.staticflickr.com/%s/%s_%s_z.jpg', $item->{server}, $item->{id}, $item->{secret};
return $item;
} else {
$log->notice ('[NOTICE] Flickr api returns empty search result list');
return;
}
} else {
return;
}
}
1;

151
lib/BotLib/Image/Imgur.pm
View File

@@ -1,151 +0,0 @@
package Botlib::Image::Imgur;
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 Math::Random::Secure qw (irand);
use Mojo::UserAgent;
use BotLib::Conf qw (LoadConf);
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (Imgur);
my $c = LoadConf ();
my $cachedir = $c->{cachedir};
sub Imgur {
my $tag = shift;
my $refresh_url = 'https://api.imgur.com/oauth2/token';
my $search_url = 'https://api.imgur.com/3/gallery/search/';
my $imgur_client_id = $c->{image}->{imgur}->{client_id} // do {
$log->error ('[ERROR] No client_id specified in config for imgur module');
return undef;
};
my $imgur_client_secret = $c->{image}->{imgur}->{client_secret} // do {
$log->error ('[ERROR] No client_secret specified in config for imgur module');
return undef;
};
my $imgur_access_token = $c->{image}->{imgur}->{access_token} // do {
$log->error ('[ERROR] No access_token specified in config for imgur module');
return undef;
};
my $imgur_refresh_token = $c->{image}->{imgur}->{refresh_token} // do {
$log->warn ('[WARN] No refresh_token specified in config for imgur module');
};
# N.B. Both imgur_access_token and imgur_refresh_token time to time can change, so we need
# some place where we can store new values
my $cache = CHI->new (
driver => 'BerkeleyDB',
root_dir => $cachedir,
namespace => __PACKAGE__
);
$imgur_access_token = $cache->get ('imgur_access_token');
# if there is no access_token in db - put there one from config
unless (defined $imgur_access_token) {
$cache->set ('imgur_access_token', $c->{image}->{imgur}->{access_token}, 'never');
}
$imgur_refresh_token = $cache->get ('imgur_refresh_token');
# if there is no refresh_token in db - put there one from config
unless (defined $imgur_refresh_token) {
$cache->set ('imgur_refresh_token', $c->{image}->{imgur}->{refresh_token}, 'never');
}
# query api
my $ua = Mojo::UserAgent->new->connect_timeout (3);
my $r = $ua->get ($search_url . $tag => {Authorization => "Bearer $imgur_access_token"})->result;
# looks like we need to refresh token
if (($r->code == 401) || ($r->code == 403)) {
$ua->post (
$refresh_url => form {
refresh_token => $imgur_refresh_token,
client_id => $imgur_client_id,
client_secret => $imgur_client_secret,
grant_type => 'refresh_token',
}
);
unless ($r->is_success) {
$log->error ("[ERROR] Unable to refresh imgur token, please re-authorise app! or imgur experiencing api outage: $r->code $r->message");
return undef;
}
my $refresh = eval { return $r->json; };
if (defined $refresh) {
$imgur_refresh_token = $refresh->{refresh_token};
$cache->set ('refresh_token', $refresh->{refresh_token}, 'never');
$imgur_access_token = $refresh->{access_token};
$cache->set ('imgur_access_token', $refresh->{access_token}, 'never');
} else {
$log->warn ("[ERROR] Unable to refresh imgur access_token, unable to decode json: $EVAL_ERROR");
return undef;
}
# query api again
$r = $ua->get ($search_url . $tag => {Authorization => "Bearer $imgur_access_token"})->result;
}
if ($r->is_success) {
my $searchResult = eval { return $r->json; };
my @urls;
if (defined $searchResult) {
if ($searchResult->{success}) {
foreach my $item (@{$searchResult->{data}}) {
foreach my $image (@{$item->{images}}) {
if (defined ($image->{animated}) && (0 + $image->{animated}) != 0) {
next;
}
if (($image->{type} eq 'image/jpeg') || ($image->{type} eq 'image/png')) {
if (defined ($image->{is_ad}) && (0 + $image->{is_ad}) !=0) {
next;
}
if (defined ($image->{nsfw}) && (0 + $image->{nsfw}) != 0) {
next;
}
push @urls, $image->{link};
}
}
}
if ($#urls > 0) {
return $urls[irand ($#urls + 1)];
} else {
$log->notice ('[NOTICE] Imgur api returned empty result.');
return undef;
}
} else {
$log->warn ("[WARN] Unable to get results from imgur api: $r->message");
return undef;
}
} else {
$log->warn ("[WARN] Unable to decode imgur api json: $EVAL_ERROR");
return undef;
}
} else {
$log->warn ("[WARN] Unable to get results from imgur api: $r->code, $r->message");
return undef;
}
}
1;

104
lib/BotLib/Karma.pm
View File

@@ -1,104 +0,0 @@
package BotLib::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 BotLib::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;
if (($phrase eq '') || ($phrase =~ /^ +$/)) {
$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;
if (($phrase eq '') || ($phrase =~ /^ +$/)) {
$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:

74
lib/BotLib/Lat.pm
View File

@@ -1,74 +0,0 @@
package BotLib::Lat;
# famous latin phases taken from https://ru.wikipedia.org/wiki/Список_крылатых_латинских_выражений
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 File::Basename qw (dirname);
use File::Path qw (make_path);
use Hailo;
use Log::Any qw ($log);
use BotLib::Conf qw (LoadConf);
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (Train Lat);
my $c = LoadConf ();
my $brain = $c->{lat}->{brain};
my $srcfile = $c->{lat}->{src};
sub Train () {
my $braindir = dirname $brain;
unless (-d $braindir) {
make_path ($braindir) or do {
cluck "Unable to create $braindir: $OS_ERROR";
exit 1;
};
}
my $lat = Hailo->new (
brain => $brain,
# in our case mean amount of words in phase is 3
order => 2
);
$lat->train ($srcfile);
my ($tokens, $expressions) = ($lat->stats ())[0,1];
printf "Total tokens: %s\nTotal expressions: %s\n", $tokens, $expressions;
$lat->save ();
return;
}
# just return answer
sub Lat () {
my $braindir = dirname $brain;
unless (-d $braindir) {
$log->error ("[ERROR] No lat module data: $braindir is absent! Train lat first.");
return '';
}
unless (-f $brain) {
$log->error ("[ERROR] No lat module data: $brain is absent! Train lat first.");
return '';
}
my $lat = Hailo->new (
brain => $brain,
# in our case mean amount of words in phase is 3
order => 2,
save_on_exit => 0
);
return $lat->reply ();
}
1;
# vim: ft=perl noet ai ts=4 sw=4 sts=4:

63
lib/BotLib/Monkeyuser.pm
View File

@@ -1,63 +0,0 @@
package BotLib::Monkeyuser;
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 HTML::TokeParser;
use Log::Any qw ($log);
use Math::Random::Secure qw (irand);
use Mojo::UserAgent;
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (Monkeyuser);
sub Monkeyuser {
my $r;
my $ret = 'Нету Monkey User-ов, они все спрятались.';
my @link;
for (1..3) {
my $ua = Mojo::UserAgent->new->connect_timeout (3);
$r = $ua->get ('https://www.monkeyuser.com/toc/')->result;
if ($r->is_success) {
last;
}
sleep 2;
}
if ($r->is_success) {
my $p = HTML::TokeParser->new(\$r->body);
my @a;
do {
$#a = -1;
@a = $p->get_tag('a'); ## no critic (Variables::RequireLocalizedPunctuationVars)
if (defined $a[0][1]->{class} && $a[0][1]->{class} eq 'lazyload small-image') {
if (defined $a[0][1]->{'data-src'} && ($a[0][1]->{'data-src'} !~ /adlitteram/)) {
push @link, $a[0][1]->{'data-src'};
}
}
} while ($#{$a[0]} > 1);
if ($#link > 0) {
$ret = sprintf '[MonkeyUser](https://www.monkeyuser.com%s)', $link [irand (1 + $#link)];
}
} else {
$log->warn (sprintf '[WARN] MonkeyUser server return status %s with message: %s', $r->{status}, $r->{reason});
}
return $ret;
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

88
lib/BotLib/Proverb.pm
View File

@@ -1,88 +0,0 @@
package BotLib::Proverb;
# Any fortune_mod sources are suitable. Text file with "\n%\n" sentence delimeter.
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Carp qw (cluck croak);
use File::Path qw (make_path);
use Log::Any qw ($log);
use Math::Random::Secure qw (irand);
use SQLite_File;
use BotLib::Conf qw (LoadConf);
use BotLib::Util qw (trim);
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (Seed Proverb);
my $c = LoadConf ();
my $dir = $c->{proverb}->{dir};
my $srcdir = $c->{proverb}->{srcdir};
sub Seed () {
unless (-d $dir) {
make_path ($dir) || croak "Unable to create $dir: $OS_ERROR";
}
my $backingfile = sprintf '%s/proverb.sqlite', $dir;
if (-f $backingfile) {
unlink $backingfile || croak "Unable to remove $backingfile: $OS_ERROR";
}
tie my @proverb, 'SQLite_File', $backingfile || croak "Unable to tie to $backingfile: $OS_ERROR";
opendir (my $srcdirhandle, $srcdir) || croak "Unable to open $srcdir: $OS_ERROR";
while (my $proverbfile = readdir ($srcdirhandle)) {
my $srcfile = sprintf '%s/%s', $srcdir, $proverbfile;
unless (-f $srcfile) {
next;
}
if ($proverbfile =~ m/^\.+$/) {
next;
}
open (my $fh, '<', $srcfile) || croak "Unable to open $srcfile, $OS_ERROR";
while (readline $fh) {
chomp;
my $str = trim ($_);
if ($str ne '') {
push @proverb, $str;
}
}
close $fh; ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
}
closedir $srcdirhandle;
untie @proverb;
return;
}
# just return answer
sub Proverb () {
my $backingfile = sprintf '%s/proverb.sqlite', $dir;
tie my @array, 'SQLite_File', $backingfile || do {
$log->error ("[ERROR] Unable to tie to $backingfile: $OS_ERROR");
return '';
};
my $phrase = $array[irand ($#array + 1)];
# decode?
utf8::decode $phrase;
untie @array;
return $phrase;
}
1;
# vim: ft=perl noet ai ts=4 sw=4 sts=4:

201
lib/BotLib/Weather.pm
View File

@@ -1,201 +0,0 @@
package BotLib::Weather;
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Carp qw (carp cluck);
use CHI;
use CHI::Driver::BerkeleyDB;
use Log::Any qw ($log);
use Mojo::Log;
use Mojo::UserAgent::Cached;
use BotLib::Conf qw (LoadConf);
use BotLib::Util qw (trim urlencode);
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (Weather);
my $c = LoadConf ();
my $cachedir = $c->{cachedir};
sub Weather {
my $city = shift;
$city = trim $city;
return 'Мне нужно ИМЯ города.' if ($city eq '');
return 'Длинновато для названия города.' if (length ($city) > 80);
$city = ucfirst $city;
if ($city eq 'Мск' || $city eq 'Default' || $city eq 'Dc' || $city eq 'Msk' || $city eq 'Dc-universe') {
$city = 'Москва';
} elsif ($city eq 'Спб' || $city eq 'Spb') {
$city = 'Санкт-Петербург';
} elsif ($city eq 'Ект' || $city eq 'Ебург' || $city eq 'Ёбург' || $city eq 'Екат' || $city eq 'Ekt' || $city eq 'Eburg' || $city eq 'Ekat') {
$city = 'Екатеринбург';
}
my $w = __weather ($city);
my $reply;
if ($w) {
if ($w->{temperature_min} == $w->{temperature_max}) {
$reply = sprintf (
"Погода в городе %s, %s:\n%s, ветер %s %s м/c, температура %s°C, ощущается как %s°C, относительная влажность %s%%, давление %s мм.рт.ст",
$w->{name},
$w->{country},
ucfirst $w->{description},
$w->{wind_direction},
$w->{wind_speed},
$w->{temperature_min},
$w->{temperature_feelslike},
$w->{humidity},
$w->{pressure}
);
} elsif ($w->{temperature_min} < 0 && $w->{temperature_max} <= 0) {
$reply = sprintf (
"Погода в городе %s, %s:\n%s, ветер %s %s м/c, температура от %s до %s°C, ощущается как %s°C, относительная влажность %s%%, давление %s мм.рт.ст",
$w->{name},
$w->{country},
ucfirst $w->{description},
$w->{wind_direction},
$w->{wind_speed},
$w->{temperature_max},
$w->{temperature_min},
$w->{temperature_feelslike},
$w->{humidity},
$w->{pressure}
);
} else {
$reply = sprintf (
"Погода в городе %s, %s:\n%s, ветер %s %s м/c, температура от %s до %s°C, ощущается как %s°C, относительная влажность %s%%, давление %s мм.рт.ст",
$w->{name},
$w->{country},
ucfirst $w->{description},
$w->{wind_direction},
$w->{wind_speed},
$w->{temperature_min},
$w->{temperature_max},
$w->{temperature_feelslike},
$w->{humidity},
$w->{pressure}
);
}
} else {
$reply = "Я не знаю, какая погода в $city";
}
return $reply;
}
sub __weather {
my $city = shift;
$city = urlencode $city;
my $appid = $c->{openweathermap}->{appid};
my $now = time ();
my $fc;
my $w;
my $r;
# try 3 times and giveup
for (1..3) {
my $ua = Mojo::UserAgent::Cached->new;
$ua->local_dir ($cachedir);
$ua->cache_agent(
CHI->new (
driver => 'BerkeleyDB',
root_dir => $cachedir,
namespace => __PACKAGE__,
expires_in => '3 hours',
expires_on_backend => 1,
)
);
# just to make Mojo::UserAgent::Cached happy
$ua->logger (Mojo::Log->new (path => '/dev/null', level => 'error'));
$r = $ua->get (sprintf ('http://api.openweathermap.org/data/2.5/weather?q=%s&lang=ru&APPID=%s', $city, $appid))->result;
if ($r->is_success) {
last;
}
sleep 2;
}
# all 3 times can give error, so check it here
if ($r->is_success) {
$fc = eval {
return $r->json;
};
unless ($fc) {
$log->warn ("[WARN] openweathermap returns corrupted json: $EVAL_ERROR");
return undef;
};
} else {
$log->warn (sprintf '[WARN] Server return status %s with message: %s', $r->code, $r->message);
return undef;
}
# TODO: check all of this for existence
$w->{'name'} = $fc->{name};
$w->{'state'} = $fc->{state};
$w->{'country'} = $fc->{sys}->{country};
$w->{'longitude'} = $fc->{coord}->{lon};
$w->{'latitude'} = $fc->{coord}->{lat};
$w->{'temperature_min'} = int ($fc->{main}->{temp_min} - 273.15);
$w->{'temperature_max'} = int ($fc->{main}->{temp_max} - 273.15);
$w->{'temperature_feelslike'} = int ($fc->{main}->{feels_like} - 273.15);
$w->{'humidity'} = $fc->{main}->{humidity};
$w->{'pressure'} = int ($fc->{main}->{pressure} * 0.75006375541921);
$w->{'description'} = $fc->{weather}->[0]->{description};
$w->{'wind_speed'} = $fc->{wind}->{speed};
$w->{'wind_direction'} = 'разный';
my $dir = int ($fc->{wind}->{deg} + 0);
if ($dir == 0) {
$w->{'wind_direction'} = 'северный';
} elsif ($dir > 0 && $dir <= 30) {
$w->{'wind_direction'} = 'северо-северо-восточный';
} elsif ($dir > 30 && $dir <= 60) {
$w->{'wind_direction'} = 'северо-восточный';
} elsif ($dir > 60 && $dir < 90) {
$w->{'wind_direction'} = 'восточно-северо-восточный';
} elsif ($dir == 90) {
$w->{'wind_direction'} = 'восточный';
} elsif ($dir > 90 && $dir <= 120) {
$w->{'wind_direction'} = 'восточно-юго-восточный';
} elsif ($dir > 120 && $dir <= 150) {
$w->{'wind_direction'} = 'юговосточный';
} elsif ($dir > 150 && $dir < 180) {
$w->{'wind_direction'} = 'юго-юго-восточный';
} elsif ($dir == 180) {
$w->{'wind_direction'} = 'южный';
} elsif ($dir > 180 && $dir <= 210) {
$w->{'wind_direction'} = 'юго-юго-западный';
} elsif ($dir > 210 && $dir <= 240) {
$w->{'wind_direction'} = 'юго-западный';
} elsif ($dir > 240 && $dir < 270) {
$w->{'wind_direction'} = 'западно-юго-западный';
} elsif ($dir == 270) {
$w->{'wind_direction'} = 'западный';
} elsif ($dir > 270 && $dir <= 300) {
$w->{'wind_direction'} = 'западно-северо-западный';
} elsif ($dir > 300 && $dir <= 330) {
$w->{'wind_direction'} = 'северо-западный';
} elsif ($dir > 330 && $dir < 360) {
$w->{'wind_direction'} = 'северо-северо-западный';
} elsif ($dir == 360) {
$w->{'wind_direction'} = 'северный';
}
return $w;
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

47
lib/BotLib/Xkcd.pm
View File

@@ -1,47 +0,0 @@
package BotLib::Xkcd;
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use Mojo::UserAgent;
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (Xkcd);
sub Xkcd {
my $ua = Mojo::UserAgent->new->connect_timeout (5)->max_redirects (0);
my $location;
my $status = 400;
my $c = 0;
do {
my $r = $ua->get ('https://xkcd.ru/random/')->result;
if (
defined $r->content &&
defined $r->content->headers &&
defined $r->content->headers->location &&
$r->content->headers->location ne ''
) {
$location = substr $r->content->headers->location, 1, -1;
$location = sprintf 'https://xkcd.ru/i/%s_v1.png', $location;
$r = $ua->head ($location)->result;
}
$c++;
$status = $r->code;
} while ($c < 3 || $status >= 404);
if ($status == 200) {
return sprintf '[xkcd.ru](%s)', $location;
}
return 'Комикс-стрип нарисовать не так-то просто :(';
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

45
lib/Cli.pm
View File

@@ -1,45 +0,0 @@
package Cli;
# общие модули - синтаксис, кодировки итд
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
# модули для работы приложения
use Mojo::Redis;
use BotLib::Conf qw (LoadConf);
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (RunCli);
my $c = LoadConf ();
sub RunCli {
my $redis = Mojo::Redis->new (
sprintf 'redis://%s:%s/1', $c->{redis_server}, $c->{redis_port}
);
my $pubsub = $redis->pubsub;
my $send_to = 'telegram';
$pubsub->json ($send_to)->notify (
$send_to => {
from => 'redis_msg_gen.pl',
userid => '0',
chatid => '0',
plugin => 'redis_msg_gen.pl_plugin',
message => 'ping?',
mode => 'private',
}
);
return;
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

16
lib/RedisLib.pm
View File

@@ -15,8 +15,7 @@ our @EXPORT_OK = qw (redis_parse_message);
sub redis_parse_message {
my $self = shift;
my $m = shift;
$log->error (Dumper $self);
my $message;
# We cannot send message if we're not connected to telegram
# TODO: Queue messages properly.
@@ -26,12 +25,13 @@ sub redis_parse_message {
}
# TODO: add some checks, at least that the bot is not muted in chat
$main::TGM->sendMessage (
{
chat_id => $m->{chatid},
text => $m->{message}
}
);
if ($m->{misc}->{msg_format}) {
$message->{parse_mode} = 'Markdown';
}
$message->{chat_id} = $m->{chatid};
$message->{text} = $m->{message};
$main::TGM->sendMessage ($message);
return;
};

284
lib/TelegramBot.pm
View File

@@ -8,8 +8,8 @@ use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Carp qw (cluck carp);
use Clone qw (clone);
use File::Path qw (make_path);
use Hailo;
use Log::Any qw ($log);
use Math::Random::Secure qw (irand);
use Mojo::Base 'Teapot::Bot::Brain';
@@ -17,12 +17,10 @@ use Mojo::Base 'Teapot::Bot::Brain';
use Protocol::Redis::XS;
use Mojo::Redis;
use Mojo::Redis::Connection;
use BotLib::Admin qw (FortuneToggleList);
use BotLib qw (RandomCommonPhrase Command Highlight BotSleep IsCensored);
use BotLib::Admin qw (FortuneToggleList ChanMsgEnabled);
use BotLib qw (Command Highlight BotSleep IsCensored);
use BotLib::Conf qw (LoadConf);
use BotLib::Fortune qw (Fortune);
use BotLib::Image qw (Oboobs Obutts);
use BotLib::Karma qw (KarmaSet);
use BotLib::Util qw (trim fmatch);
use RedisLib qw (redis_parse_message);
@@ -31,7 +29,6 @@ use Exporter qw (import);
our @EXPORT_OK = qw (RunTelegramBot);
my $c = LoadConf ();
my $hailo;
my $myid;
my $myusername;
my $myfirst_name;
@@ -40,25 +37,42 @@ my $myfullname;
has token => $c->{telegrambot}->{token};
my $redismsg->{from} = 'telegram';
$redismsg->{plugin} = 'telegram';
$redismsg->{misc}->{answer} = 1;
$redismsg->{misc}->{csign} = $c->{telegrambot}->{csign};
$redismsg->{misc}->{msg_format} = 0;
$redismsg->{misc}->{fwd_cnt} = 1;
sub __cron {
my $self = shift;
# fortune mod
my @intro = (
'Сегодняшний день пройдёт под эгидой фразы:',
'Крылатая фраза на сегодня:',
'Сегодняшняя фраза дня:',
);
my $rmsg = clone ($redismsg);
$rmsg->{mode} = 'public';
# Press 'F' to pay respect
$rmsg->{message} = sprintf '%sf', $c->{telegrambot}->{csign};
$rmsg->{misc}->{good_morning} = 1;
$rmsg->{misc}->{msg_format} = 1;
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime (time);
{
do {
my $ready = eval { $main::RCONN->is_connected; };
last if ($ready);
} while (sleep 1);
}
my $pubsub = $main::REDIS->pubsub;
if ($hour == 8 && ($min >= 0 && $min <= 14)) {
foreach my $enabledfortunechat (FortuneToggleList ()) {
my $send_args;
$send_args->{text} = sprintf "%s\n```\n%s\n```\n", $intro[irand ($#intro + 1)], trim (Fortune ());
$send_args->{chat_id} = $enabledfortunechat;
$send_args->{parse_mode} = 'Markdown';
$self->sendMessage ($send_args);
$rmsg->{userid} = $enabledfortunechat;
$rmsg->{chatid} = $enabledfortunechat;
$pubsub->json ($c->{'redis_router_channel'})->notify (
$c->{'redis_router_channel'} => $rmsg
);
}
}
@@ -160,23 +174,6 @@ sub __on_msg {
return;
}
# lazy init chat-bot brains
unless (defined $hailo->{$chatid}) {
my $brainname = sprintf '%s/%s.brain.sqlite', $c->{telegrambot}->{braindir}, $chatid;
$hailo->{$chatid} = Hailo->new (
# we'll got file like this: data/telegrambot-brains/-1001332512695.brain.sqlite
brain => $brainname,
order => 3
);
if ($chatid < 0) {
$log->info ("[INFO] Initialized brain for public chat $chatname ($chatid): $brainname");
} else {
$log->info ("[INFO] Initialized brain for private chat $chatname ($chatid): $brainname");
}
}
# is this a 1-on-1 ?
if ($msg->chat->type eq 'private') {
unless (defined $msg->text) {
@@ -185,62 +182,27 @@ sub __on_msg {
my $text = $msg->text;
$log->debug (sprintf ('[DEBUG] Private chat %s say to bot: %s', $vis_a_vi, $text));
# Ответ по-умолчанию
my $reply = 'Давайте ещё пообщаемся, а то я ещё не научилась от вас плохому.';
if (substr ($text, 0, 1) eq $csign) {
# Если текст похож на команду, усылаем его в BotLib.pm
$reply = Command ($self, $msg, $text, $userid);
} else {
my $just_message_in_chat = 0;
my $rmsg = clone ($redismsg);
$rmsg->{mode} = 'private';
$rmsg->{message} = $text;
$rmsg->{userid} = $userid;
$rmsg->{chatid} = $userid;
my $pubsub = $main::REDIS->pubsub;
$pubsub->json ($c->{'redis_router_channel'})->notify (
$c->{'redis_router_channel'} => $rmsg
);
# is it karma adjustment?
if (substr ($text, -2) eq '++' || substr ($text, -2) eq '--') {
my @arr = split /\n/, $text;
if ($#arr < 1) {
$reply = KarmaSet ($chatid, trim (substr ($text, 0, -2)), substr ($text, -2));
} else {
$just_message_in_chat = 1;
}
} else {
$just_message_in_chat = 1;
}
if ($just_message_in_chat) {
if ($text =~ /^ *кто +все +эти +люди *\?$/ui) {
$reply = 'Какие "люди"? Мы здесь вдвоём, только ты и я.';
} elsif ($text =~ /^ *кто +я *\?$/ui) {
$reply = 'Где?';
} elsif ($text =~ /^ *кто +(здесь|тут) *\?$/ui) {
$reply = 'Ты да я, да мы с тобой.';
} elsif ($text =~ /покажи +(сиськи|сиси|титьки) *$/ui) {
$reply = Oboobs ();
} elsif ($text =~ /show +(titts|tities|boobs) *$/i) {
$reply = Oboobs ();
} elsif ($text =~ /покажи +(попку|попу) *$/ui) {
$reply = Obutts ();
} elsif ($text =~ /show +(ass|butt|butty) *$/i) {
$reply = Obutts ();
} else {
my $str = $hailo->{$msg->chat->id}->learn_reply ($text);
if (defined ($str) && $str ne '') {
$reply = $str;
$phrase = trim $text;
while ($phrase =~ /[\.|\,|\?|\!]$/) {
chop $phrase;
}
$phrase = lc $phrase;
if (fmatch (lc ($reply), $phrase)) {
$reply = RandomCommonPhrase ();
}
}
}
}
return;
}
# Команды раздела Admin ответ таки возвращают
if (defined $reply) {
$msg->typing ();
sleep 1;
@@ -251,46 +213,75 @@ sub __on_msg {
} elsif (($msg->chat->type eq 'supergroup') or ($msg->chat->type eq 'group')) {
my $reply;
# Некоторые виды сообщений можно "зацензурить" ботом, например, голосовые сообщения, картинки итд.
# И вот тут как раз такая проверка и происходит
if (IsCensored $msg) {
$log->info (sprintf '[INFO] In public chat %s (%s) message from %s was censored', $chatname, $chatid, $vis_a_vi);
$self->deleteMessage ({chat_id => $chatid, message_id => $msg->{message_id}});
}
# detect and log messages without text, noop here
# Некоторые рекламные товарищи пыьаются срать своими каналами в чятик это тоже можно зацензурить ботом и это
# пидорство он будет удалять asap
# 136817688 - это специальный id пользователя, который принимает облик канала, на него можно нажать и попасть
# на рекламируемый канал
if ($msg->from->id == 136817688) {
my $sender_chat = eval { $msg->sender_chat->id };
if (defined $sender_chat) {
unless (ChanMsgEnabled ($chatid)) {
$self->deleteMessage ({chat_id => $chatid, message_id => $msg->{message_id}});
}
}
}
# Если обнаруживаем здесь сообщение без текста, просто ничего не делаем и выходим из процедуры обработки
# сообщения
unless (defined $msg->text) {
$log->debug (sprintf ('[DEBUG] No text in message from %s', $vis_a_vi));
return;
}
# we have text here! so potentially we can chit-chat
# Текст есть, потенциально можно будет поболтать!
my $text = $msg->text;
$log->debug (sprintf ('[DEBUG] In public chat %s (%s) %s say: %s', $chatname, $chatid, $vis_a_vi, $text));
# are they quote something, maybe, us?
# Если это ответ на сообщение, то вдруг, на наше?
if (defined ($msg->reply_to_message) &&
defined ($msg->reply_to_message->from) &&
defined ($msg->reply_to_message->from->username) &&
($msg->reply_to_message->from->username eq $myusername)) {
$log->debug (sprintf ('[DEBUG] In public chat %s (%s) %s quote us!', $chatname, $chatid, $vis_a_vi));
# do not answer back if someone quote our new member greet
# Если новый участник чата ответил на наше приветствие, проигнорируем его ответ (и попробуем сойти за
# человека :)
if ((substr ($msg->reply_to_message->text, 0, 9) eq 'Дратути, ') &&
(substr ($msg->reply_to_message->text, -61) eq 'Представьтес, пожалуйста, и расскажите, что вас сюда привело.')) {
return;
} else {
# remove our name from users reply, just in case
# На всякий случай, попробуем убрать наше имя из фразы.
my $pat1 = quotemeta ('@' . $myusername);
my $pat2 = quotemeta $myfullname;
$phrase = $text;
$phrase =~ s/$pat1//g;
$phrase =~ s/$pat2//g;
# figure out reply :)
$reply = $hailo->{$msg->chat->id}->learn_reply ($phrase) if (length ($phrase) > 3);
# Попробуем сгенерить ответ
my $rmsg = clone ($redismsg);
$rmsg->{mode} = 'public';
$rmsg->{message} = $phrase;
$rmsg->{userid} = $userid;
$rmsg->{chatid} = $chatid;
my $pubsub = $main::REDIS->pubsub;
$pubsub->json ($c->{'redis_router_channel'})->notify (
$c->{'redis_router_channel'} => $rmsg
);
return;
}
# simple commands
# Если текст похож на команду, усылаем его в BotLib.pm
} elsif (substr ($text, 0, 1) eq $csign) {
$reply = Command ($self, $msg, $text, $chatid);
# Похоже кто-то написал наше имя в чятике, но ничего не захотел дописывать к нему
} elsif (
($text eq $myusername) or
($text eq '@' . $myusername) or
@@ -299,6 +290,7 @@ sub __on_msg {
($text eq $myfullname . ' ')
) {
$reply = 'Чего?';
# А тут кто-то к нам обратился с чем-то по имени
} else {
my $qname = quotemeta ('@' . $myusername);
my $qtname = quotemeta $myfullname;
@@ -307,63 +299,61 @@ sub __on_msg {
if ((lc ($text) =~ /^${qname}[\,|\:]? (.+)/) or (lc ($text) =~ /^${qtname}[\,|\:]? (.+)/)){
$phrase = $1;
if ($phrase =~ /^ *кто +все +эти +люди *\?$/ui) {
$reply = 'Кто здесь?';
} elsif ($phrase =~ /^ *кто +я *?$/ui){
$reply = 'Где?';
} elsif ($phrase =~ /^ *кто +(здесь|тут) *\?$/ui) {
$reply = 'Здесь все: Никита, Стас, Гена, Турбо и Дюша Метёлкин.';
} else {
$reply = $hailo->{$msg->chat->id}->learn_reply ($phrase);
}
my $rmsg = clone ($redismsg);
$rmsg->{mode} = 'public';
$rmsg->{message} = $phrase;
$rmsg->{userid} = $userid;
$rmsg->{chatid} = $chatid;
my $pubsub = $main::REDIS->pubsub;
$pubsub->json ($c->{'redis_router_channel'})->notify (
$c->{'redis_router_channel'} => $rmsg
);
return;
# bot mention by name
} elsif ((lc ($text) =~ /.+ ${qname}[\,|\!|\?|\.| ]/) or (lc ($text) =~ / $qname$/)) {
$phrase = $text;
if ($phrase =~ /^ *кто +все +эти +люди *\?$/ui) {
$reply = 'Кто здесь?';
} elsif ($phrase =~ /^ *кто +я *?$/ui){
$reply = 'Где?';
} elsif ($phrase =~ /^ *кто +(здесь|тут) *\?$/ui) {
$reply = 'Здесь все: Никита, Стас, Гена, Турбо и Дюша Метёлкин.';
} else {
$reply = $hailo->{$msg->chat->id}->learn_reply ($phrase);
}
my $rmsg = clone ($redismsg);
$rmsg->{mode} = 'public';
$rmsg->{message} = $phrase;
$rmsg->{userid} = $userid;
$rmsg->{chatid} = $chatid;
my $pubsub = $main::REDIS->pubsub;
$pubsub->json ($c->{'redis_router_channel'})->notify (
$c->{'redis_router_channel'} => $rmsg
);
return;
# bot mention by telegram name
} elsif ((lc ($text) =~ /.+ ${qtname}[\,|\!|\?|\.| ]/) or (lc ($text) =~ / $qtname$/)) {
$phrase = $text;
if ($phrase =~ /^ *кто +все +эти +люди *\?$/ui) {
$reply = 'Кто здесь?';
} elsif ($phrase =~ /^ *кто +я *?$/ui){
$reply = 'Где?';
} elsif ($phrase =~ /^ *кто +(здесь|тут) *\?$/ui) {
$reply = 'Здесь все: Никита, Стас, Гена, Турбо и Дюша Метёлкин.';
} else {
$reply = $hailo->{$msg->chat->id}->learn_reply ($phrase);
}
# karma adjustment
} elsif (substr ($text, -2) eq '++' || substr ($text, -2) eq '--') {
my @arr = split /\n/, $text;
my $rmsg = clone ($redismsg);
$rmsg->{mode} = 'public';
$rmsg->{message} = $phrase;
$rmsg->{userid} = $userid;
$rmsg->{chatid} = $chatid;
my $pubsub = $main::REDIS->pubsub;
$pubsub->json ($c->{'redis_router_channel'})->notify (
$c->{'redis_router_channel'} => $rmsg
);
if ($#arr < 1) {
$reply = KarmaSet ($chatid, trim (substr ($text, 0, -2)), substr ($text, -2));
} else {
# just message in chat
$hailo->{$msg->chat->id}->learn ($text);
}
# just message in chat
} else {
if ($text =~ /^ *кто +все +эти +люди *\?$/ui) {
$reply = 'Кто здесь?';
} elsif ($phrase =~ /^ *кто +я *?$/ui){
$reply = 'Где?';
} elsif ($phrase =~ /^ *кто +(здесь|тут) *\?$/ui) {
$reply = 'Здесь все: Никита, Стас, Гена, Турбо и Дюша Метёлкин.';
} else {
$hailo->{$msg->chat->id}->learn ($text);
}
return;
}
my $rmsg = clone ($redismsg);
$rmsg->{mode} = 'public';
$rmsg->{message} = $text;
$rmsg->{userid} = $userid;
$rmsg->{chatid} = $chatid;
$rmsg->{misc}->{answer} = 0;
my $pubsub = $main::REDIS->pubsub;
$pubsub->json ($c->{'redis_router_channel'})->notify (
$c->{'redis_router_channel'} => $rmsg
);
return;
}
if (defined ($reply) && $reply ne '') {
@@ -455,6 +445,24 @@ sub __redisListener {
return;
}
sub RandomCommonPhrase {
my @myphrase = (
'Так, блядь...',
'*Закатывает рукава* И ради этого ты меня позвал?',
'Ну чего ты начинаешь, нормально же общались',
'Повтори свой вопрос, не поняла',
'Выйди и зайди нормально',
'Я подумаю',
'Даже не знаю, что на это ответить',
'Ты упал такие вопросы девочке задавать?',
'Можно и так, но не уверена',
'А как ты думаешь?',
'А ви, таки, почему интересуетесь?',
);
return $myphrase[irand ($#myphrase + 1)];
}
# setup our bot
sub init {
my $self = shift;