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

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

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

103
lib/BotLib/Admin.pm
View File

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

88
lib/BotLib/Anek.pm
View File

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

60
lib/BotLib/Buni.pm
View File

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

115
lib/BotLib/Drink.pm
View File

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

86
lib/BotLib/Fortune.pm
View File

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

96
lib/BotLib/Friday.pm
View File

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

241
lib/BotLib/Image.pm
View File

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

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

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

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

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

104
lib/BotLib/Karma.pm
View File

@@ -1,104 +0,0 @@
package BotLib::Karma;
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Carp qw (cluck);
use CHI;
use CHI::Driver::BerkeleyDB;
use Log::Any qw ($log);
use BotLib::Conf qw (LoadConf);
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (KarmaSet KarmaGet);
my $c = LoadConf ();
my $cachedir = $c->{cachedir};
my $max = 5;
# swallow phrase and return answer
sub KarmaSet (@) {
my $chatid = shift;
my $phrase = shift;
my $action = shift;
if (($phrase eq '') || ($phrase =~ /^ +$/)) {
$phrase = ' ';
}
my $cache = CHI->new (
driver => 'BerkeleyDB',
root_dir => $cachedir,
namespace => __PACKAGE__ . '_' . $chatid
);
my $score = $cache->get ($phrase);
if (defined $score) {
if ($action eq '++') {
$score++;
} else {
$score--;
}
} else {
if ($action eq '++') {
$score = 1;
} else {
$score = -1;
}
}
if ($cache->set ($phrase, $score, 'never') != $score) {
$log->error ('[ERROR] Cache error: unable to set karma.');
}
if ($score < -1 && (($score % (0 - $max)) + 1) == 0) {
if ($phrase eq ' ') {
return sprintf 'Зарегистрировано пробитие дна, карма пустоты составляет %d', $score;
} else {
return sprintf 'Зарегистрировано пробитие дна, карма %s составляет %d', $phrase, $score;
}
} else {
if ($phrase eq ' ') {
return sprintf 'Карма пустоты составляет %d', $score;
} else {
return sprintf 'Карма %s составляет %d', $phrase, $score;
}
}
}
# just return answer
sub KarmaGet (@) {
my $chatid = shift;
my $phrase = shift;
if (($phrase eq '') || ($phrase =~ /^ +$/)) {
$phrase = ' ';
}
my $cache = CHI->new (
driver => 'BerkeleyDB',
root_dir => $cachedir,
namespace => __PACKAGE__ . '_' . $chatid
);
my $score = $cache->get ($phrase);
unless (defined $score) {
$score = 0;
}
if ($phrase eq ' ') {
return sprintf 'Карма пустоты составляет %d', $score;
} else {
return sprintf 'Карма %s составляет %d', $phrase, $score;
}
}
1;
# vim: ft=perl noet ai ts=4 sw=4 sts=4:

74
lib/BotLib/Lat.pm
View File

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

63
lib/BotLib/Monkeyuser.pm
View File

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

88
lib/BotLib/Proverb.pm
View File

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

201
lib/BotLib/Weather.pm
View File

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

47
lib/BotLib/Xkcd.pm
View File

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