0

Initial commit

This commit is contained in:
eleksir
2021-08-01 00:09:02 +03:00
committed by Sergei Fedosov
commit 2f3e3f764e
38 changed files with 6567 additions and 0 deletions

76
lib/BotLib/Anek.pm Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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: