Initial commit
This commit is contained in:
76
lib/BotLib/Anek.pm
Normal file
76
lib/BotLib/Anek.pm
Normal file
@@ -0,0 +1,76 @@
|
||||
package BotLib::Anek;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw (:std :utf8);
|
||||
use English qw ( -no_match_vars );
|
||||
use Carp qw (carp);
|
||||
use Encode;
|
||||
use HTML::TokeParser;
|
||||
use HTTP::Tiny;
|
||||
use JSON::XS;
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (Anek);
|
||||
|
||||
sub Anek {
|
||||
my $r;
|
||||
my $ret = 'Все рассказчики анекдотов отдыхают';
|
||||
for (1..3) {
|
||||
my $ua = HTTP::Tiny->new (timeout => 3);
|
||||
$r = $ua->get ('https://www.anekdot.ru/rss/randomu.html');
|
||||
|
||||
if ($r->{success}) {
|
||||
last;
|
||||
}
|
||||
|
||||
sleep 2;
|
||||
}
|
||||
|
||||
if ($r->{success}) {
|
||||
my $json;
|
||||
my $response_text = decode ('UTF-8', $r->{content});
|
||||
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;
|
||||
chop $json;
|
||||
chop $json;
|
||||
chop $json;
|
||||
my $anek = eval { ${JSON::XS->new->relaxed->decode ($json)}[0] };
|
||||
|
||||
if (defined $anek) {
|
||||
my @anek = split (/<br>/, $anek);
|
||||
$ret = join ("\n", @anek);
|
||||
} else {
|
||||
carp (sprintf "[WARN] anekdot.ru server returns incorrect json, full response text message: %s\n", $response_text);
|
||||
}
|
||||
} else {
|
||||
carp (sprintf "[WARN] anekdot.ru server returns unexpected response text: %s\n", $response_text);
|
||||
}
|
||||
|
||||
} else {
|
||||
carp (sprintf "[WARN] anekdot.ru server return status %s with message: %s\n", $r->code, $r->message);
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
126
lib/BotLib/Archeologist.pm
Normal file
126
lib/BotLib/Archeologist.pm
Normal file
@@ -0,0 +1,126 @@
|
||||
package BotLib::Archeologist;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw (:std :utf8);
|
||||
use English qw ( -no_match_vars );
|
||||
use Math::Random::Secure qw (irand);
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (Dig);
|
||||
|
||||
sub Dig {
|
||||
my $name = shift;
|
||||
|
||||
my @artifact = (
|
||||
'амулет Мерлина',
|
||||
'библиотеку Ивана Грозного',
|
||||
'деревянную плошку',
|
||||
'диплока',
|
||||
'доски Ноева Ковчега',
|
||||
'древний презерватив из бараньей кишки',
|
||||
'икону',
|
||||
'инсталятор Windows 3.11',
|
||||
'истлевший гроб',
|
||||
'каменный топор',
|
||||
'клад со златом-серебром',
|
||||
'кривой нож',
|
||||
'ледяную глыбу',
|
||||
'лунный грунт',
|
||||
'мамонта',
|
||||
'мамонтенка',
|
||||
'метеорит',
|
||||
'мумию фараона Тутанхамона',
|
||||
'носки прапорщика (поставит в угол)',
|
||||
'обломки грузинской керамики',
|
||||
'птеродактиля',
|
||||
'рубль с Лениным',
|
||||
'рыцарские доспехи',
|
||||
'синий мох',
|
||||
'скелет',
|
||||
'скелет собаки по кличке Беня',
|
||||
'тиранозавтра',
|
||||
'тотем индейцев',
|
||||
'трубу с туркменским газом',
|
||||
'скорбь еврейского народа',
|
||||
'залежи активированного угля',
|
||||
'не очень новый завет',
|
||||
'мать леннарта поттеринга',
|
||||
'руководство "начинающему археологу"',
|
||||
'слово о полку игореве и дело о полку игореве, вместе с игорем',
|
||||
'телепрограмму канала A-one',
|
||||
'могилу искателя могил',
|
||||
'заплесневевший кусок хлеба',
|
||||
'преемник радиоприемника',
|
||||
'глушитель от ВАЗ-2106',
|
||||
'чувство удовлетворения',
|
||||
'крота',
|
||||
'воспоминания о былой любви',
|
||||
'грязистор',
|
||||
'египетское мумиё',
|
||||
'окаменелый камень',
|
||||
'кладку яиц рептилоида',
|
||||
'яму',
|
||||
'чеснок и стрелы',
|
||||
'доллар по 30',
|
||||
'несмазанные скрижали',
|
||||
'четырелобита',
|
||||
'чучело тролля',
|
||||
'целое ничего',
|
||||
);
|
||||
|
||||
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";
|
||||
|
||||
if ($success_probability <= 25) {
|
||||
$phrase .= sprintf '%s стал лучшим археологом, выкопав %s! возраст артефакта - %s лет!', $name, $artifact[irand ($#artifact + 1)], $artifact_age;
|
||||
} else {
|
||||
$phrase .= sprintf "Поздравляю, %s! Вы только что выкопали %s, возраст - %s лет!\n", $name, $artifact[irand ($#artifact + 1)], $artifact_age;
|
||||
$phrase .= sprintf 'Извини %s, но на артефакт это не тянет! Однако, попытка хорошая!', $name;
|
||||
}
|
||||
|
||||
return $phrase;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
58
lib/BotLib/Buni.pm
Normal file
58
lib/BotLib/Buni.pm
Normal file
@@ -0,0 +1,58 @@
|
||||
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 (carp);
|
||||
use HTTP::Tiny;
|
||||
use HTML::TokeParser;
|
||||
|
||||
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 $http = HTTP::Tiny->new (timeout => 3);
|
||||
$r = $http->get ('http://www.bunicomic.com/?random&nocache=1');
|
||||
|
||||
if ($r->{success}) {
|
||||
last;
|
||||
}
|
||||
|
||||
sleep 2;
|
||||
}
|
||||
|
||||
if ($r->{success}) {
|
||||
my $p = HTML::TokeParser->new(\$r->{content});
|
||||
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 = $a[0][1]->{content};
|
||||
last;
|
||||
}
|
||||
|
||||
} while ($#{$a[0]} > 1);
|
||||
}
|
||||
} else {
|
||||
carp (sprintf "[WARN] Server return status %s with message: %s\n", $r->{status}, $r->{reason});
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
41
lib/BotLib/Conf.pm
Normal file
41
lib/BotLib/Conf.pm
Normal file
@@ -0,0 +1,41 @@
|
||||
package BotLib::Conf;
|
||||
# loads config
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw (:std :utf8);
|
||||
use English qw ( -no_match_vars );
|
||||
use Carp qw (carp);
|
||||
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 "[FATA] No conf at $c: $OS_ERROR\n";
|
||||
my $len = (stat $c) [7];
|
||||
my $json;
|
||||
my $readlen = read $CH, $json, $len;
|
||||
|
||||
unless ($readlen) {
|
||||
close $CH; ## no critic (InputOutput::RequireCheckedSyscalls
|
||||
carp ("[FATA] Unable to read $c: $OS_ERROR\n");
|
||||
}
|
||||
|
||||
if ($readlen != $len) {
|
||||
close $CH; ## no critic (InputOutput::RequireCheckedSyscalls
|
||||
carp ("[FATA] File $c is $len bytes on disk, but we read only $readlen bytes\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:
|
||||
124
lib/BotLib/Drink.pm
Normal file
124
lib/BotLib/Drink.pm
Normal file
@@ -0,0 +1,124 @@
|
||||
package BotLib::Drink;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw (:std :utf8);
|
||||
use English qw ( -no_match_vars );
|
||||
use Carp qw (carp);
|
||||
use Encode;
|
||||
use CHI;
|
||||
use CHI::Driver::BerkeleyDB;
|
||||
use DateTime;
|
||||
use HTTP::Tiny;
|
||||
use HTML::TokeParser;
|
||||
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 ();
|
||||
|
||||
sub Drink {
|
||||
my $drinkCallBack = sub {
|
||||
my $ret;
|
||||
my ($dayNum, $monthNum) = (localtime ())[3, 4];
|
||||
my $url = sprintf 'https://kakoysegodnyaprazdnik.ru/baza/%s/%s', $MONTH[$monthNum], $dayNum;
|
||||
my $r;
|
||||
|
||||
for (1..3) {
|
||||
my $http = HTTP::Tiny->new (timeout => 3);
|
||||
$r = $http->get ($url, {'Accept-Charset' => 'utf-8', 'Accept-Language' => 'ru-RU'});
|
||||
|
||||
if ($r->{success}) {
|
||||
last;
|
||||
}
|
||||
|
||||
sleep 2;
|
||||
}
|
||||
|
||||
if ($r->{success}) {
|
||||
# TODO: Handle unexpected content
|
||||
my $p = HTML::TokeParser->new (\$r->{content});
|
||||
my @a;
|
||||
my @holiday;
|
||||
|
||||
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 @holiday,'* ' . decode ('UTF-8', $p->get_trimmed_text ('/span'));
|
||||
}
|
||||
|
||||
} while ($#{$a[0]} > 1);
|
||||
|
||||
if ($#holiday > 0) {
|
||||
# cut off something weird, definely not a "holyday"
|
||||
$#holiday = $#holiday - 1;
|
||||
}
|
||||
|
||||
if ($#holiday > 0) {
|
||||
$ret = join "\n", @holiday;
|
||||
}
|
||||
} else {
|
||||
carp (sprintf "[WARN] Server return status %s with message: %s\n", $r->{status}, $r->{reason});
|
||||
return undef;
|
||||
}
|
||||
|
||||
return $ret;
|
||||
};
|
||||
|
||||
my $cache = CHI->new (
|
||||
driver => 'BerkeleyDB',
|
||||
root_dir => $c->{cachedir},
|
||||
namespace => __PACKAGE__
|
||||
);
|
||||
|
||||
# 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;
|
||||
}
|
||||
|
||||
# Okay, now we have correct unix timestamp, heh
|
||||
my $res = $cache->compute (
|
||||
'Holiday',
|
||||
{ expires_at => $expirationDate },
|
||||
$drinkCallBack
|
||||
);
|
||||
|
||||
if (defined $res && $res ne '') {
|
||||
return $res;
|
||||
} else {
|
||||
return 'Не знаю праздников - вджобываю весь день на шахтах, как проклятая.';
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
133
lib/BotLib/Fisher.pm
Normal file
133
lib/BotLib/Fisher.pm
Normal file
@@ -0,0 +1,133 @@
|
||||
package BotLib::Fisher;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw (:std :utf8);
|
||||
use English qw ( -no_match_vars );
|
||||
use Math::Random::Secure qw (irand);
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (Fish);
|
||||
|
||||
|
||||
sub Fish {
|
||||
my $name = shift;
|
||||
|
||||
my @artifact = (
|
||||
'семикрылого чешуйчатого пятихуя',
|
||||
'разумного конденсатора',
|
||||
'сальмонеллу',
|
||||
'селёдку',
|
||||
'желтоперого тунца',
|
||||
'розовую сальмонеллу',
|
||||
'голавля',
|
||||
'барбуса',
|
||||
'окуня',
|
||||
'верхоплавку',
|
||||
'коричневую форель',
|
||||
'полярника',
|
||||
'плотву',
|
||||
'зубатку',
|
||||
'солнечную рыбу',
|
||||
'старую шину',
|
||||
'скользкую корягу',
|
||||
'лампу джина',
|
||||
'любовное послание в бутылке',
|
||||
'старое бревно',
|
||||
'резиновый сапог',
|
||||
'труп',
|
||||
'Лох-Несское чудовище',
|
||||
'старую рыбацкую приманку',
|
||||
'кусок Титаника',
|
||||
'обломок Атлантиды',
|
||||
'кита',
|
||||
'кальмара',
|
||||
'дельфина',
|
||||
'ската',
|
||||
'подводную лодку',
|
||||
'медузу',
|
||||
'морскую звезду',
|
||||
'электрического угря',
|
||||
'большую белую акулу',
|
||||
'аквалангиста',
|
||||
'монстра',
|
||||
'вируса',
|
||||
'сырую пачку сигарет',
|
||||
'водоросли',
|
||||
'якорь от лодки',
|
||||
'водяного',
|
||||
'русалку',
|
||||
'палтуса',
|
||||
'труп собаки по кличке Беня',
|
||||
'олигофрена Проню',
|
||||
'огеймера Фишкина',
|
||||
);
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
$phrase .= sprintf "Поздравляю, %s! Вы только что поймали %s! аж на %d кило!\n\n", $name, $artifact[irand ($#artifact + 1)], $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:
|
||||
85
lib/BotLib/Fortune.pm
Normal file
85
lib/BotLib/Fortune.pm
Normal file
@@ -0,0 +1,85 @@
|
||||
package BotLib::Fortune;
|
||||
# Any fortune_mod sources are suitable. Text file with "\n%\n" sentence delimiters.
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw (:std :utf8);
|
||||
use English qw ( -no_match_vars );
|
||||
use Carp qw (croak carp);
|
||||
use File::Path qw (make_path);
|
||||
use Math::Random::Secure qw (irand);
|
||||
use MIME::Base64;
|
||||
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\n";
|
||||
}
|
||||
|
||||
tie my @fortune, 'SQLite_File', $backingfile || croak "Unable to tie to $backingfile: $OS_ERROR\n";
|
||||
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\n";
|
||||
# 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 {
|
||||
carp ("[ERROR] Unable to tie to $backingfile: $OS_ERROR\n");
|
||||
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:
|
||||
54
lib/BotLib/Fox.pm
Normal file
54
lib/BotLib/Fox.pm
Normal file
@@ -0,0 +1,54 @@
|
||||
package BotLib::Fox;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw (:std :utf8);
|
||||
use English qw ( -no_match_vars );
|
||||
use Carp qw (carp);
|
||||
use JSON::XS;
|
||||
use HTTP::Tiny;
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (Fox);
|
||||
|
||||
sub Fox {
|
||||
my $r;
|
||||
my $ret = 'Нету лисичек, все разбежались.';
|
||||
|
||||
for (1..3) {
|
||||
my $http = HTTP::Tiny->new (timeout => 3);
|
||||
$r = $http->get ('https://randomfox.ca/floof/');
|
||||
|
||||
if ($r->{success}) {
|
||||
last;
|
||||
}
|
||||
|
||||
sleep 2;
|
||||
}
|
||||
|
||||
if ($r->{success}) {
|
||||
my $jfox = eval {
|
||||
decode_json ($r->{content})
|
||||
};
|
||||
|
||||
unless (defined $jfox) {
|
||||
carp ("[WARN] Unable to decode JSON: $EVAL_ERROR\n");
|
||||
} else {
|
||||
if ($jfox->{image}) {
|
||||
$jfox->{image} =~ s/\\//xmsg;
|
||||
$ret = $jfox->{image};
|
||||
}
|
||||
}
|
||||
} else {
|
||||
carp (sprintf "[WARN] Server return status %s with message: %s\n", $r->{status}, $r->{reason});
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
96
lib/BotLib/Friday.pm
Normal file
96
lib/BotLib/Friday.pm
Normal file
@@ -0,0 +1,96 @@
|
||||
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 (croak carp);
|
||||
use File::Path qw (make_path);
|
||||
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 {
|
||||
carp ("[ERROR] Unable to tie to $backingfile: $OS_ERROR\n");
|
||||
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:
|
||||
70
lib/BotLib/Image.pm
Normal file
70
lib/BotLib/Image.pm
Normal file
@@ -0,0 +1,70 @@
|
||||
package BotLib::Image;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw (:std :utf8);
|
||||
use BotLib::Image::Flickr qw (FlickrByTags);
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (Rabbit Owl Frog Horse Snail);
|
||||
|
||||
sub Rabbit {
|
||||
# rabbit, but bunny
|
||||
my $url = FlickrByTags ('animal,bunny');
|
||||
|
||||
if (defined $url) {
|
||||
return $url;
|
||||
} else {
|
||||
return 'Нету кроликов, все разбежались.';
|
||||
}
|
||||
}
|
||||
|
||||
sub Owl {
|
||||
my $url = FlickrByTags ('bird,owl');
|
||||
|
||||
if (defined $url) {
|
||||
return $url;
|
||||
} else {
|
||||
return 'Нету сов, все разлетелись.';
|
||||
}
|
||||
}
|
||||
|
||||
sub Frog {
|
||||
# unable to find any one-line ascii art for frog :(
|
||||
my $url = FlickrByTags ('frog,toad,amphibian');
|
||||
|
||||
if (defined $url) {
|
||||
return $url;
|
||||
} else {
|
||||
return 'Нету лягушек, все свалили.';
|
||||
}
|
||||
}
|
||||
|
||||
sub Horse {
|
||||
# unable to find any one-line ascii art for frog :(
|
||||
my $url = FlickrByTags ('horse,equine,mammal');
|
||||
|
||||
if (defined $url) {
|
||||
return $url;
|
||||
} else {
|
||||
return 'Нету коняшек, все разбежались.';
|
||||
}
|
||||
}
|
||||
|
||||
sub Snail {
|
||||
# unable to find any one-line ascii art for frog :(
|
||||
my $url = FlickrByTags ('snail,slug');
|
||||
|
||||
if (defined $url) {
|
||||
return $url;
|
||||
} else {
|
||||
return 'Нету улиток, все расползлись.';
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
639
lib/BotLib/Image/Flickr.pm
Normal file
639
lib/BotLib/Image/Flickr.pm
Normal file
@@ -0,0 +1,639 @@
|
||||
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 (carp);
|
||||
use Digest::HMAC_SHA1 qw (hmac_sha1);
|
||||
use File::Path qw (make_path);
|
||||
use JSON::XS;
|
||||
use HTTP::Tiny;
|
||||
use Math::Random::Secure qw (irand);
|
||||
use MIME::Base64;
|
||||
use SQLite_File;
|
||||
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 $dir = $c->{image}->{dir};
|
||||
|
||||
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 flickrSignReq {
|
||||
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 = flickrSignReq (
|
||||
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 $http = HTTP::Tiny->new (timeout => 5);
|
||||
my $r = $http->get ($url);
|
||||
my %params;
|
||||
|
||||
if ($r->{success}) {
|
||||
# they ignore format=json, so...
|
||||
%params = map {split /=/} split /&/, $r->{content};
|
||||
} else {
|
||||
say "Something bad returns from flickr api: $r->{status} $r->{content}"; ## 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 = flickrSignReq (
|
||||
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 $http = HTTP::Tiny->new (timeout => 5);
|
||||
my $r = $http->get ($url);
|
||||
my %params;
|
||||
|
||||
if ($r->{success}) {
|
||||
# they ignore format=json
|
||||
%params = map {split /=/} split /&/, $r->{content};
|
||||
} else {
|
||||
say "Something bad returns from flickr api: $r->{status} $r->{content}"; ## 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 $http = HTTP::Tiny->new (timeout => 5);
|
||||
my $r = $http->get ($url);
|
||||
|
||||
if ($r->{success}) {
|
||||
return $r->{url};
|
||||
} else {
|
||||
say "Something went wrong: $r->{status} $r->{content}"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
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 = flickrSignReq (
|
||||
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 $http = HTTP::Tiny->new (timeout => 5);
|
||||
my $r = $http->get ($url);
|
||||
|
||||
if ($r->{success}) {
|
||||
my $response = eval {
|
||||
my $j = JSON::XS->new->utf8->relaxed;
|
||||
return $j->decode ($r->{content});
|
||||
};
|
||||
|
||||
if (defined $response) {
|
||||
say Dumper $response; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
return 1;
|
||||
} else {
|
||||
say "Flickr api returns incorrect json: $r->{content}"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
return 0;
|
||||
}
|
||||
} else {
|
||||
say "HTTP status code not 200: $r->{status}, $r>{contenr}"; ## 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 = flickrSignReq (
|
||||
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 $http = HTTP::Tiny->new (timeout => 5);
|
||||
my $r = $http->get ($url);
|
||||
|
||||
if ($r->{success}) {
|
||||
my $response = eval {
|
||||
my $j = JSON::XS->new->utf8->relaxed;
|
||||
return $j->decode ($r->{content});
|
||||
};
|
||||
|
||||
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 = flickrSignReq (
|
||||
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)
|
||||
);
|
||||
|
||||
$http = HTTP::Tiny->new (timeout => 5);
|
||||
$r = $http->get ($url);
|
||||
|
||||
if ($r->{success}) {
|
||||
$response = eval {
|
||||
my $j = JSON::XS->new->utf8->relaxed;
|
||||
return $j->decode ($r->{content});
|
||||
};
|
||||
|
||||
if (defined $response) {
|
||||
return $response;
|
||||
} else {
|
||||
carp ("[WARN] Flickr api returns incorrect json: $r->{content}\n");
|
||||
return undef;
|
||||
}
|
||||
} else {
|
||||
carp ("[WARN] Flickr api returns incorrect json: $r->{content}\n");
|
||||
return undef;
|
||||
}
|
||||
} else {
|
||||
carp ("[WARN] Flickr api returns incorrect json: $r->{content}\n");
|
||||
return undef;
|
||||
}
|
||||
} else {
|
||||
carp ("[WARN] HTTP status code not 200: $r->{status}, $r->{content}\n");
|
||||
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 = flickrSignReq (
|
||||
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 $http = HTTP::Tiny->new (timeout => 5);
|
||||
my $r = $http->get ($url);
|
||||
|
||||
if ($r->{success}) {
|
||||
my $response = eval {
|
||||
my $j = JSON::XS->new->utf8->relaxed;
|
||||
return $j->decode ($r->{content});
|
||||
};
|
||||
|
||||
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 = flickrSignReq (
|
||||
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)
|
||||
);
|
||||
|
||||
$http = HTTP::Tiny->new (timeout => 5);
|
||||
$r = $http->get ($url);
|
||||
|
||||
if ($r->{success}) {
|
||||
$response = eval {
|
||||
my $j = JSON::XS->new->utf8->relaxed;
|
||||
return $j->decode ($r->{content});
|
||||
};
|
||||
|
||||
if (defined $response) {
|
||||
return $response;
|
||||
} else {
|
||||
carp ("[WARN] Flickr api returns incorrect json: $r->{content}\n");
|
||||
return undef;
|
||||
}
|
||||
} else {
|
||||
carp ("[WARN] Flickr api returns incorrect json: $r->{content}\n");
|
||||
return undef;
|
||||
}
|
||||
} else {
|
||||
carp ("[WARN] Flickr api returns incorrect json: $r->{content}\n");
|
||||
return undef;
|
||||
}
|
||||
} else {
|
||||
carp ("[WARN] HTTP status code not 200: $r->{status}, $r>{content}\n");
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
sub FlickrInit {
|
||||
my $backingfile = sprintf '%s/secrets.sqlite', $dir;
|
||||
|
||||
unless (-d $dir) {
|
||||
make_path ($dir) or do {
|
||||
say "Unable to create $dir: $OS_ERROR"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
return 0;
|
||||
};
|
||||
}
|
||||
|
||||
tie my %secret, 'SQLite_File', $backingfile || do {
|
||||
say "[ERROR] Unable to tie to $backingfile: $OS_ERROR"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
return 0;
|
||||
};
|
||||
|
||||
if (defined $flickr_verifier && $flickr_verifier) {
|
||||
my $flickr_request_token = $secret{flickr_request_token};
|
||||
my $flickr_request_token_secret = $secret{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 $backingfile"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
say 'Please remove verifier settings from config.json and run this script again'; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
untie %secret;
|
||||
return 0;
|
||||
}
|
||||
|
||||
my %accessToken = flickrAccessToken ($flickr_request_token, $flickr_request_token_secret, $flickr_verifier);
|
||||
|
||||
if (defined ($accessToken{oauth_token}) && defined ($accessToken{oauth_token_secret})) {
|
||||
$secret{flickr_access_token} = $accessToken{oauth_token};
|
||||
$secret{flickr_access_token_secret} = $accessToken{oauth_token_secret};
|
||||
|
||||
say sprintf ( ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
'Access token (%s) and access token secret (%s) are in %s',
|
||||
$accessToken{oauth_token},
|
||||
$accessToken{oauth_token_secret},
|
||||
$backingfile
|
||||
);
|
||||
|
||||
untie %secret;
|
||||
return 1;
|
||||
}
|
||||
} else {
|
||||
my %req = flickrRequestToken ();
|
||||
if (defined ($req{oauth_token}) && defined ($req{oauth_token_secret}) && defined ($req{oauth_token})) {
|
||||
$secret{flickr_request_token} = $req{oauth_token};
|
||||
$secret{flickr_request_token_secret} = $req{oauth_token_secret};
|
||||
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)
|
||||
untie %secret;
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
untie %secret;
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub FlickrTestLogin {
|
||||
my $text = shift;
|
||||
my $backingfile = sprintf '%s/secrets.sqlite', $dir;
|
||||
|
||||
unless (-d $dir) {
|
||||
make_path ($dir) or do {
|
||||
say "Unable to create $dir: $OS_ERROR"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
return 0;
|
||||
};
|
||||
}
|
||||
|
||||
tie my %secret, 'SQLite_File', $backingfile || do {
|
||||
say "Unable to tie to $backingfile: $OS_ERROR"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
return 0;
|
||||
};
|
||||
|
||||
my $flickr_access_token = $secret{flickr_access_token};
|
||||
my $flickr_access_token_secret = $secret{flickr_access_token_secret};
|
||||
untie %secret;
|
||||
|
||||
if (flickrTestLogin ($flickr_access_token, $flickr_access_token_secret)) {
|
||||
return 1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
sub FlickrByTags {
|
||||
my $text = shift;
|
||||
my $backingfile = sprintf '%s/secrets.sqlite', $dir;
|
||||
|
||||
unless (-d $dir) {
|
||||
make_path ($dir) or do {
|
||||
carp ("[ERROR] Unable to create $dir: $OS_ERROR\n");
|
||||
return 0;
|
||||
};
|
||||
}
|
||||
|
||||
tie my %secret, 'SQLite_File', $backingfile || do {
|
||||
carp ("[ERROR] Unable to tie to $backingfile: $OS_ERROR\n");
|
||||
return 0;
|
||||
};
|
||||
|
||||
my $flickr_access_token = $secret{flickr_access_token};
|
||||
my $flickr_access_token_secret = $secret{flickr_access_token_secret};
|
||||
untie %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 {
|
||||
carp ("[NOTICE] Flickr api returns empty search result list\n");
|
||||
return;
|
||||
}
|
||||
} else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
sub FlickrByText {
|
||||
my $text = shift;
|
||||
my $backingfile = sprintf '%s/secrets.sqlite', $dir;
|
||||
|
||||
unless (-d $dir) {
|
||||
make_path ($dir) or do {
|
||||
carp ("[ERROR] Unable to create $dir: $OS_ERROR\n");
|
||||
return 0;
|
||||
};
|
||||
}
|
||||
|
||||
tie my %secret, 'SQLite_File', $backingfile || do {
|
||||
carp ("[ERROR] Unable to tie to $backingfile: $OS_ERROR\n");
|
||||
return 0;
|
||||
};
|
||||
|
||||
my $flickr_access_token = $secret{flickr_access_token};
|
||||
my $flickr_access_token_secret = $secret{flickr_access_token_secret};
|
||||
untie %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 {
|
||||
carp ("[NOTICE] Flickr api returns empty search result list\n");
|
||||
return;
|
||||
}
|
||||
} else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
125
lib/BotLib/Karma.pm
Normal file
125
lib/BotLib/Karma.pm
Normal file
@@ -0,0 +1,125 @@
|
||||
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 (carp);
|
||||
use DB_File;
|
||||
use File::Path qw (make_path);
|
||||
use BotLib::Conf qw (LoadConf);
|
||||
use BotLib::Util qw (utf2sha1 trim);
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (KarmaSet KarmaGet);
|
||||
|
||||
my $c = LoadConf ();
|
||||
my $karmadir = $c->{karma}->{dir};
|
||||
my $max = 5;
|
||||
|
||||
# swallow phrase and return answer
|
||||
sub KarmaSet (@) {
|
||||
my $chatid = shift;
|
||||
my $phrase = shift;
|
||||
my $action = shift;
|
||||
$phrase = trim $phrase;
|
||||
my $score = 0;
|
||||
# sha1* does not understand utf8, so explicitly construct string cost of decimal numbers only
|
||||
my $karmafile = utf2sha1 $chatid;
|
||||
$karmafile =~ s/\//-/xmsg;
|
||||
$karmafile = sprintf '%s/%s.db', $karmadir, $karmafile;
|
||||
|
||||
unless (-d $karmadir) {
|
||||
make_path ($karmadir) or do {
|
||||
carp ("[ERROR] Unable to create $karmadir: $OS_ERROR\n");
|
||||
return sprintf 'Карма %s составляет 0', $phrase;
|
||||
};
|
||||
}
|
||||
|
||||
# init hash, store phrase and score
|
||||
tie my %karma, 'DB_File', $karmafile || do {
|
||||
carp ("[ERROR] Something nasty happen when karma ties to its data: $OS_ERROR\n");
|
||||
return sprintf 'Карма %s составляет 0', $phrase;
|
||||
};
|
||||
|
||||
# bdb does not understand utf8, so tied hash too, we do not want store original phrase anyway
|
||||
my $sha1_phrase = utf2sha1 $phrase;
|
||||
|
||||
if (defined $karma{$sha1_phrase}) {
|
||||
if ($action eq '++') {
|
||||
$score = $karma{$sha1_phrase} + 1;
|
||||
$karma{$sha1_phrase} = $score;
|
||||
} else {
|
||||
$score = $karma{$sha1_phrase} - 1;
|
||||
$karma{$sha1_phrase} = $score;
|
||||
}
|
||||
} else {
|
||||
if ($action eq '++') {
|
||||
$karma{$sha1_phrase} = 1;
|
||||
$score = 1;
|
||||
} else {
|
||||
$karma{$sha1_phrase} = -1;
|
||||
$score = -1;
|
||||
}
|
||||
}
|
||||
|
||||
untie %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;
|
||||
my $karmafile = utf2sha1 $chatid;
|
||||
$karmafile =~ s/\//-/xmsg;
|
||||
$karmafile = sprintf '%s/%s.db', $karmadir, $karmafile;
|
||||
|
||||
unless (-d $karmadir) {
|
||||
make_path ($karmadir) or do {
|
||||
carp ("Unable to create $karmadir: $OS_ERROR\n");
|
||||
return sprintf 'Карма %s составляет 0', $phrase;
|
||||
};
|
||||
}
|
||||
|
||||
# init hash, store phrase and score
|
||||
tie my %karma, 'DB_File', $karmafile || do {
|
||||
carp ("[ERROR] Something nasty happen when karma ties to its data: $OS_ERROR\n");
|
||||
return sprintf 'Карма %s составляет 0', $phrase;
|
||||
};
|
||||
|
||||
my $sha1_phrase = utf2sha1 $phrase;
|
||||
my $score = $karma{$sha1_phrase};
|
||||
untie %karma;
|
||||
|
||||
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:
|
||||
53
lib/BotLib/Kitty.pm
Normal file
53
lib/BotLib/Kitty.pm
Normal file
@@ -0,0 +1,53 @@
|
||||
package BotLib::Kitty;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw (:std :utf8);
|
||||
use English qw ( -no_match_vars );
|
||||
use Carp qw (carp);
|
||||
use JSON::XS;
|
||||
use HTTP::Tiny;
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (Kitty);
|
||||
|
||||
sub Kitty {
|
||||
my $r;
|
||||
my $ret = 'Нету кошечек, все разбежались.';
|
||||
|
||||
for (1..3) {
|
||||
my $http = HTTP::Tiny->new (timeout => 3);
|
||||
$r = $http->get ('https://api.thecatapi.com/v1/images/search');
|
||||
|
||||
if ($r->{success}) {
|
||||
last;
|
||||
}
|
||||
|
||||
sleep 2;
|
||||
}
|
||||
|
||||
if ($r->{success}) {
|
||||
my $jcat = eval {
|
||||
decode_json ($r->{content})
|
||||
};
|
||||
|
||||
unless (defined $jcat) {
|
||||
carp ("[ERROR] Unable to decode JSON: $EVAL_ERROR\n");
|
||||
} else {
|
||||
if ($jcat->[0]->{url}) {
|
||||
$ret = $jcat->[0]->{url};
|
||||
}
|
||||
}
|
||||
} else {
|
||||
carp (sprintf "Server return status %s with message: %s\n", $r->{status}, $r->{reason});
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
73
lib/BotLib/Lat.pm
Normal file
73
lib/BotLib/Lat.pm
Normal file
@@ -0,0 +1,73 @@
|
||||
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 (carp);
|
||||
use File::Basename qw (dirname);
|
||||
use File::Path qw (make_path);
|
||||
use Hailo;
|
||||
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 {
|
||||
carp "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) {
|
||||
carp ("[ERROR] No lat module data: $braindir is absent! Train lat first.\n");
|
||||
return '';
|
||||
}
|
||||
|
||||
unless (-f $brain) {
|
||||
carp ("[ERROR] No lat module data: $brain is absent! Train lat first.\n");
|
||||
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:
|
||||
62
lib/BotLib/Monkeyuser.pm
Normal file
62
lib/BotLib/Monkeyuser.pm
Normal file
@@ -0,0 +1,62 @@
|
||||
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 (carp);
|
||||
use HTTP::Tiny;
|
||||
use HTML::TokeParser;
|
||||
use Math::Random::Secure qw (irand);
|
||||
|
||||
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 $http = HTTP::Tiny->new (timeout => 3);
|
||||
$r = $http->get ('https://www.monkeyuser.com/toc/');
|
||||
|
||||
if ($r->{success}) {
|
||||
last;
|
||||
}
|
||||
|
||||
sleep 2;
|
||||
}
|
||||
|
||||
if ($r->{success}) {
|
||||
my $p = HTML::TokeParser->new(\$r->{content});
|
||||
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 'https://www.monkeyuser.com%s', $link[irand (1 + $#link)];
|
||||
}
|
||||
} else {
|
||||
carp (sprintf "[WARN] Monkeyuser server return status %s with message: %s\n", $r->{status}, $r->{reason});
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
116
lib/BotLib/Util.pm
Normal file
116
lib/BotLib/Util.pm
Normal file
@@ -0,0 +1,116 @@
|
||||
package BotLib::Util;
|
||||
|
||||
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 Digest::SHA qw (sha1_base64);
|
||||
use Encode;
|
||||
use MIME::Base64;
|
||||
use Text::Fuzzy qw (distance_edits);
|
||||
use URI::URL;
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (trim urlencode fmatch utf2b64 utf2sha1);
|
||||
|
||||
sub trim {
|
||||
my $str = shift;
|
||||
|
||||
unless (defined $str) {
|
||||
cluck '[ERROR] Str is undefined';
|
||||
return '';
|
||||
}
|
||||
|
||||
if ($str eq '') {
|
||||
return $str;
|
||||
}
|
||||
|
||||
while (substr ($str, 0, 1) =~ /^\s$/xms) {
|
||||
$str = substr $str, 1;
|
||||
}
|
||||
|
||||
while (substr ($str, -1, 1) =~ /^\s$/xms) {
|
||||
chop $str;
|
||||
}
|
||||
|
||||
return $str;
|
||||
}
|
||||
|
||||
sub urlencode {
|
||||
my $str = shift;
|
||||
|
||||
unless (defined $str) {
|
||||
cluck '[ERROR] Str is undefined';
|
||||
return '';
|
||||
}
|
||||
|
||||
my $urlobj = url $str;
|
||||
return $urlobj->as_string;
|
||||
}
|
||||
|
||||
sub fmatch {
|
||||
my $srcphrase = shift;
|
||||
my $answer = shift;
|
||||
|
||||
if ((! defined $srcphrase) || (! defined $answer)) {
|
||||
if (defined $srcphrase) {
|
||||
cluck '[ERROR] Answer undefined';
|
||||
} elsif (defined $answer) {
|
||||
cluck '[ERROR] Srcphrase undefined';
|
||||
} else {
|
||||
cluck '[ERROR] Both srcphrase and answer are undefined';
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
my ($distance, undef) = distance_edits ($srcphrase, $answer);
|
||||
my $srcphraselen = length $srcphrase;
|
||||
my $distance_max = int ($srcphraselen - ($srcphraselen * (100 - (90 / ($srcphraselen ** 0.5))) * 0.01));
|
||||
|
||||
if ($distance >= $distance_max) {
|
||||
return 0;
|
||||
} else {
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
sub utf2b64 {
|
||||
my $string = shift;
|
||||
|
||||
unless (defined $string) {
|
||||
cluck '[ERROR] String is undefined';
|
||||
return sha1_base64 '';
|
||||
}
|
||||
|
||||
if ($string eq '') {
|
||||
return encode_base64 '';
|
||||
}
|
||||
|
||||
my $bytes = encode_utf8 $string;
|
||||
return encode_base64 $bytes;
|
||||
}
|
||||
|
||||
sub utf2sha1 {
|
||||
my $string = shift;
|
||||
|
||||
unless (defined $string) {
|
||||
cluck '[ERROR] String is undefined';
|
||||
return sha1_base64 '';
|
||||
}
|
||||
|
||||
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:
|
||||
176
lib/BotLib/Weather.pm
Normal file
176
lib/BotLib/Weather.pm
Normal file
@@ -0,0 +1,176 @@
|
||||
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 HTTP::Tiny;
|
||||
use JSON::XS;
|
||||
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 ();
|
||||
|
||||
sub Weather {
|
||||
my $city = shift;
|
||||
$city = trim $city;
|
||||
|
||||
return 'Мне нужно ИМЯ города.' if ($city eq '');
|
||||
return 'Длинновато для названия города.' if (length ($city) > 80);
|
||||
|
||||
$city = ucfirst $city;
|
||||
|
||||
my $weatherCallBack = sub {
|
||||
my $appid = $c->{openweathermap}->{appid};
|
||||
|
||||
unless (defined $appid) {
|
||||
carp ("[WARN] No appid specified for openweathermap\n");
|
||||
return undef;
|
||||
}
|
||||
|
||||
my $fc;
|
||||
my $w;
|
||||
my $r;
|
||||
|
||||
# try 3 times and giveup
|
||||
for (1..3) {
|
||||
my $http = HTTP::Tiny->new (timeout => 3);
|
||||
$r = $http->get (sprintf ('http://api.openweathermap.org/data/2.5/weather?q=%s&lang=ru&APPID=%s', urlencode ($city), $appid));
|
||||
|
||||
if ($r->{success}) {
|
||||
last;
|
||||
}
|
||||
|
||||
sleep 2;
|
||||
}
|
||||
|
||||
# all 3 times can give error, so check it here
|
||||
if ($r->{success}) {
|
||||
$fc = eval {
|
||||
decode_json ($r->{content});
|
||||
};
|
||||
|
||||
unless (defined $fc) {
|
||||
carp ("[WARN] openweathermap returns corrupted json: $EVAL_ERROR\n");
|
||||
return undef;
|
||||
};
|
||||
} else {
|
||||
carp (sprintf "Server return status %s with message: %s\n", $r->{status}, $r->{reason});
|
||||
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;
|
||||
};
|
||||
|
||||
my $cache = CHI->new (
|
||||
driver => 'BerkeleyDB',
|
||||
root_dir => $c->{cachedir},
|
||||
namespace => __PACKAGE__
|
||||
);
|
||||
|
||||
my $w = $cache->compute (
|
||||
$city,
|
||||
'3 hours',
|
||||
$weatherCallBack
|
||||
);
|
||||
|
||||
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}
|
||||
);
|
||||
} 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;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
42
lib/BotLib/Xkcd.pm
Normal file
42
lib/BotLib/Xkcd.pm
Normal file
@@ -0,0 +1,42 @@
|
||||
package BotLib::Xkcd;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw (:std :utf8);
|
||||
use HTTP::Tiny;
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (Xkcd);
|
||||
|
||||
sub Xkcd {
|
||||
my $http = HTTP::Tiny->new (timeout => 5, max_redirect => 0);
|
||||
my $location;
|
||||
my $status = 400;
|
||||
my $c = 0;
|
||||
|
||||
do {
|
||||
my $r = $http->get ('https://xkcd.ru/random/');
|
||||
|
||||
if (defined $r->{headers} && defined $r->{headers}->{location} && $r->{headers}->{location} ne '') {
|
||||
$location = substr ($r->{headers}->{location}, 1, -1);
|
||||
$location = sprintf 'https://xkcd.ru/i/%s_v1.png', $location;
|
||||
$r = $http->head ($location);
|
||||
}
|
||||
|
||||
$c++;
|
||||
$status = $r->{status};
|
||||
} while ($c < 3 || $status >= 404);
|
||||
|
||||
if ($status == 200) {
|
||||
return $location;
|
||||
}
|
||||
|
||||
return 'Комикс-стрип нарисовать не так-то просто :(';
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
Reference in New Issue
Block a user