aleesa-bot/aleesa-webapp
Archived
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Prepare for first run

Browse Source
This commit is contained in:
eleksir
2022-01-01 19:23:40 +03:00
parent c96911f5f8
commit c44ab2376b
23 changed files with 1093 additions and 1276 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
.perlcriticrc
View File

@@ -93,3 +93,4 @@ lib_sections = NAME | VERSION | DESCRIPTION | AUTHOR | LICENSE AND COPYRIGHT
[-ControlStructures::ProhibitDeepNests]
# Have to use it, so fuckoff
[-Variables::ProhibitPackageVars]

122
README
View File

@@ -1,113 +1,67 @@
aleesa-weba
------------------------------------------------------------------------------
Клиент для различных веб-приложений и API.
Работает по протоколу Redis pubsub.
aleesa-webapp
-----------------------------------------------------------------------------------------------------------------------
Клиент для различных веб-приложений и API. Работает по протоколу Redis pubsub.
Механика работы
------------------------------------------------------------------------------
Клиент подписан на все каналы, попадающие под шаблон "webapp:*" (без кавычек).
Предполагается, что есть специальный канал "broadcast", на который
подписываются все модули и, если надо, ответ в такой канал получают все.
-----------------------------------------------------------------------------------------------------------------------
Клиент подписан на на redis-канал craniac. В этот канал пишет другой демоночек - aleesa-misc.
Формат протокола - это json с полями:
from - модуль, который решил отправить запрос.
chatid - чат, из которого сделан вызов
userid - пользователь, на чью фразу мы отвечаем
message - оригинальный текст сообщения
plugin - плагин, нужный для генерации ответа
misc - объект с дополнительными полями, здесь все поля опциональны и
специфичны для задействованных плагинов
N.B.
При запуске нового приложения, которое будет пользоваться этим клиентом, оно
должно "поприветствовать" клиента по всем каналам, для того, чтобы сработала
внутренняя логика и клиент подписался на новые каналы. Если этого не сделать,
то первое сообщение по новому каналу будет "проглочено" и "потрачено" на
подписку на этот канал.
Плагины и команды
------------------------------------------------------------------------------
TBD: Описать список плагинов и команд, которые их триггерят.
Формат протокола
Плагин для работы с flickr
------------------------------------------------------------------------------
Этот плагин используется для добычи ссылок на картинки в разных "картиночных"
командах бота.
----------------------------------------------------------------------------------------------------------------------
Этот плагин используется для добычи ссылок на картинки в разных "картиночных" командах бота.
Есть скрипт, который поможет с регистрацией приложения в api Flickr -
bin/flickr_init.pl он достанет все нужные ключи и секреты к ним.
Есть скрипт, который поможет с регистрацией приложения в api Flickr - bin/flickr_init.pl он достанет все нужные ключи
и секреты к ним.
До запуска этого скрипта, бот должен быть забутстраплен через bootstrap.sh.
Залогиньтесь https://identity.flickr.com/login и создайте app
https://www.flickr.com/services/apps/create/apply/ в своём Flicker-овском
аккаунте.
Залогиньтесь https://identity.flickr.com/login и создайте app https://www.flickr.com/services/apps/create/apply/ в
своём Flicker-овском аккаунте.
Запишите app key и secret https://home.openweathermap.org/api_keys в
config.json. Удостоверьтесь, что параметр "verifier" в конфиге либо закоменчен
либо отсутствует.
Запишите app key и secret https://home.openweathermap.org/api_keys в config.json. Удостоверьтесь, что параметр
"verifier" в конфиге либо закоменчен либо отсутствует.
Далее, разлогиньтесь, это нужно, чтобы потом проще было достать параметр
verifier.
Далее, разлогиньтесь, это нужно, чтобы потом проще было достать параметр verifier.
Запустите bin/flickr_init.pl и следуте предлагаемым инструкциям - в итоге
будет дана ссылка, которую надо скопипастить в браузер. По ссылке предложат
залогиниться, далее надо будет разрешить приложению просматривать профиль и
через один-два редиректа вы попадёте на example.com. Из адресной строки
браузера надо скопировать параметр "verifier" и вписать его в config.json.
Запустите bin/flickr_init.pl и следуте предлагаемым инструкциям - в итоге будет дана ссылка, которую надо скопипастить
в браузер. По ссылке предложат залогиниться, далее надо будет разрешить приложению просматривать профиль и через
один-два редиректа вы попадёте на example.com. Из адресной строки браузера надо скопировать параметр "verifier" и
вписать его в config.json.
Чтобы сохранить в бд плагина API access token для нормальной работы плагина,
второй раз запустите bin/flickr_init.pl. На этом всё.
Чтобы сохранить в бд плагина API access token для нормальной работы плагина, второй раз запустите bin/flickr_init.pl.
На этом всё.
Плагин OpenWeatherMap
------------------------------------------------------------------------------
-----------------------------------------------------------------------------------------------------------------------
Для работы погодного плагина надо заргистрироваться на сайте OWM
https://home.openweathermap.org/users/sign_in , залогиниться
https://home.openweathermap.org/users/sign_in и создать api key
https://home.openweathermap.org/api_keys . Free plan предлагает всё необхдимое
для работы плагина.
https://home.openweathermap.org/api_keys . Free plan предлагает всё необхдимое для работы плагина.
Когда api key будет создан, его нужно вписать в config.json в секцию
openweathermap в качестве appid. На этом всё.
Когда api key будет создан, его нужно вписать в config.json в секцию openweathermap в качестве appid. На этом всё.
Как это запустить?
------------------------------------------------------------------------------
Понадобится perl, cpanm и local::lib, а также несколько разных devel-пакетов
для разных библиотек. Как правило, это находится методом тыка, но точно
понадобятся zlib-devel, openssl-devel, sqlite-devel, bdb-devel (или db-devel).
Кроме того, понадобятся development tools - gcc, gcc-g++, perl-devel, make,
cmake и так далее.
-----------------------------------------------------------------------------------------------------------------------
Понадобится perl, cpanm и local::lib, а также несколько разных devel-пакетов для разных библиотек. Как правило, это
находится методом тыка, но точно понадобятся sqlite-devel, bdb-devel (или db-devel), hiredis-devel. Кроме того,
понадобятся development tools - gcc, gcc-g++, perl-devel, make, cmake и так далее.
В каталоге с приложением под целевым пользователем запускаем bash bootstrap.sh
Ждём с надеждой, что оно не обломится в пути.
Приложение тестировалось на alpine linux x86_64 3.12, со встроенным perl-5.32.1
Если всё хорошо, то после создания data/config.json из data/config_sample.json
и получения ключей и настройки модулей openweathermap и flickr, можно
запускать приложение. Оно запустится как unix daemon.
В каталоге с приложением под целевым пользователем запускаем bash bootstrap.sh Ждём с надеждой, что оно не обломится в
пути.
Если всё хорошо, то после запуска redis-а, создания data/config.json из data/config_sample.json, можно запускать и само
приложение.
Тест
------------------------------------------------------------------------------
Версии перловых модулей в cpanfile не закреплены, поэтому после их бутстрапа
желательно проверить, что ничего не развалилось.
Для начала нужно запустить redis и удостовериться, что настройки в
data/config.json верны. После этого можно переходить к тестам.
Первый тест удостоверяется, что модули в принципе работают. Запускаем
bin/test-sub.pl, потом bin/test-pub.pl. В консоли, где запущен bin/test-sub.pl
должны появиться сообщения, визуально похожие на json. При этом ошибок быть не
должно.
Второй тест тыкает в приложение и удостоверяется, что оно формально работает.
Запускаем само приложение bin/aleesa-weba, оно уходит в фон. Притэйливаемся
к его логам (настройки в data/config.json). Запускаем bin/test.pl. В консоли
этого скрипта должны начать появляться сообщения, похожие на json. Ошибок быть
не должно ни в консоли теста ни в логе, к которому мы притэйлились.
Если тесты работают не взрываясь - работает и приложение.
В каталоге contrib находится скрипт для alpine linux, системы инициализации openrc. Этот скрипт достаточно положить В
/etc/init.d/aleesa-misc сконфигурить сервис по инструкции выше и после этого сервис запускается командой:
service aleesa-misc start
в автозагрузку его можно прописать через команду
rc-update add aleesa-misc default

4
bin/aleesa-weba → bin/aleesa-webapp
View File

@@ -112,9 +112,9 @@ if (defined $logfile) {
}
# по-умолчанию, демонизируемся, если явно не указано, что этого делать не надо
if (defined ($c->{daemonize}) && $c->{daemonize}) {
if (defined ($C->{daemonize}) && $C->{daemonize}) {
daemonize ();
} elsif ( ! defined ($c->{daemonize})) {
} elsif ( ! defined ($C->{daemonize})) {
daemonize ();
}

29
bin/flickr_init.pl Normal file
View File

@@ -0,0 +1,29 @@
#!/usr/bin/perl
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use version; our $VERSION = qw (1.0);
my $workdir;
# before we run, change working dir
BEGIN {
use Cwd qw (chdir abs_path);
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
$workdir = join '/', @CWD;
chdir $workdir;
}
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
use WebApp::Client::API::Flickr qw (FlickrInit);
if (FlickrInit ()) {
exit 0;
} else {
exit 1;
}

49
bin/test-pub.pl
View File

@@ -1,49 +0,0 @@
#!/usr/bin/perl
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use version; our $VERSION = qw (1.0);
my $workdir;
# before we run, change working dir
BEGIN {
use Cwd qw (chdir abs_path);
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
$workdir = join '/', @CWD;
chdir $workdir;
}
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
use Mojo::Redis;
use Conf qw (LoadConf);
my $c = LoadConf ();
my $redis = Mojo::Redis->new (
sprintf 'redis://%s:%s/1', $c->{server}, $c->{port}
);
my $pubsub = $redis->pubsub;
my @messages = ('!cat', '!fox', '!drink', '!monkeyuser', '!xkcd');
while (1) {
$pubsub->json ('webapp:TEST')->notify (
'webapp:TEST' => {
from => 'test-pub.pl',
userid => 'test_user',
chatid => '#test_chat',
plugin => 'dummy_plugin',
message => $messages [int (rand ($#messages + 1))]
}
);
sleep 3;
}
exit 0;

53
bin/test-sub.pl
View File

@@ -1,53 +0,0 @@
#!/usr/bin/perl
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use version; our $VERSION = qw (1.0);
my $workdir;
# before we run, change working dir
BEGIN {
use Cwd qw (chdir abs_path);
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
$workdir = join '/', @CWD;
chdir $workdir;
}
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
use Carp qw (carp);
use Mojo::Redis;
use Data::Dumper;
use Conf qw (LoadConf);
my $c = LoadConf ();
my $redis = Mojo::Redis->new (
sprintf 'redis://%s:%s/1', $c->{server}, $c->{port}
);
my $pubsub = $redis->pubsub;
$pubsub->json('webapp:TEST')->listen (
'webapp:TEST' => sub {
my $self = shift;
my $message = shift;
carp Dumper ($message);
}
);
$pubsub->json('broadcast')->listen (
'broadcast' => sub {
my $self = shift;
my $message = shift;
carp Dumper ($message);
}
);
Mojo::IOLoop->start unless Mojo::IOLoop->is_running;

88
bin/test.pl
View File

@@ -1,88 +0,0 @@
#!/usr/bin/perl
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use version; our $VERSION = qw (1.0);
my $workdir;
# before we run, change working dir
BEGIN {
use Cwd qw (chdir abs_path);
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
$workdir = join '/', @CWD;
chdir $workdir;
}
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
use Carp qw (carp);
use Mojo::Redis;
use Data::Dumper;
use Conf qw (LoadConf);
my @messages = ('!cat', '!fox', '!drink', '!monkeyuser', '!xkcd');
my $c = LoadConf ();
my $redis = Mojo::Redis->new (
sprintf 'redis://%s:%s/1', $c->{server}, $c->{port}
);
my $pubsub = $redis->pubsub;
# Добавим коллбэк на приход события в test.
$pubsub->json ('test')->listen (
'test' => sub {
# my $self = shift;
# my $message = shift;
carp Dumper (@_);
}
);
# Добавим коллбэк на приход события в broadcast.
$pubsub->json ('broadcast')->listen (
'broadcast' => sub {
# my $self = shift;
# my $message = shift;
carp Dumper (@_);
}
);
# Попробуем потыкать в наш сервер приложений разными сообщениями.
# Этот коллбэк запускается по таймеру, раз в 3 секунды.
Mojo::IOLoop->recurring (
3 => sub {
my $channel = 'test';
if (int (rand (2))) { $channel = 'broadcast' }
$pubsub->json ('webapp:test')->notify (
'webapp:test' => {
from => $channel, # <- отвечаем в этот pubsub-канал
userid => 'test_user',
chatid => '#test_chat',
plugin => 'dummy_plugin',
message => $messages [int (rand ($#messages + 1))]
}
);
}
);
# поприветствуем наше тестируемое приложение, это необходимо чтобы оно подписалось на нас.
$pubsub->json ('webapp:TEST')->notify (
'webapp:TEST' => {
from => 'test', # <- отвечаем в этот pubsub-канал
userid => 'test_user',
chatid => '#test_chat',
plugin => 'dummy_plugin',
message => 'Hello'
}
);
# Приветствовать test не нужно, так как он безо всякой эвристики подписан и на себя и на broadcast
# Все нужные обработчики напиханы в ивент-луп, можно его запускать.
Mojo::IOLoop->start unless Mojo::IOLoop->is_running;

11
contrib/aleesa-webapp.openrc Normal file
View File

@@ -0,0 +1,11 @@
#!/sbin/openrc-run
name="$SVCNAME"
command="/var/lib/$SVCNAME/bin/$SVCNAME"
pidfile="/var/run/$SVCNAME/$SVCNAME.pid"
depend() {
need net redis
use dns
after redis
}

63
cpanfile
View File

@@ -1,36 +1,27 @@
requires 'AnyEvent::Redis';
requires 'Carp';
requires 'CHI';
requires 'CHI::Driver::BerkeleyDB';
requires 'Cwd::utf8';
requires 'DateTime';
requires 'DB_File';
requires 'DBI';
requires 'DBD::SQLite';
requires 'Digest::HMAC_SHA1';
requires 'Digest::MD5';
requires 'Digest::SHA';
requires 'Encode';
requires 'EV';
requires 'File::Basename';
requires 'File::Path';
requires 'Hailo';
requires 'HTML::TokeParser';
requires 'HTTP::Tiny';
requires 'IO::Socket::SSL';
requires 'JSON';
requires 'JSON::XS';
requires 'List::Util';
requires 'local::lib';
requires 'Log::Any';
requires 'Log::Any::Adapter';
requires 'Log::Any::For::Std';
requires 'Math::Random::Secure';
requires 'MIME::Base64';
requires 'Mojo::Redis';
requires 'POSIX';
requires 'SQLite_File';
requires 'String::Random';
requires 'Text::Fuzzy';
requires 'URI::Encode::XS';
requires 'URI::URL';
requires 'Carp', '0';
requires 'CHI', '==0.61';
requires 'CHI::Driver::BerkeleyDB', '==0.05';
requires 'Cwd::utf8', '==0.011';
requires 'DateTime', '==1.55';
requires 'Digest::HMAC_SHA1', '==1.04';
requires 'Encode', '==3.16';
requires 'EV', '==4.33';
requires 'File::Basename', '0';
requires 'File::Path', '==2.18';
requires 'HTML::TokeParser', '==3.76';
requires 'IO::Socket::SSL', '==2.073';
requires 'JSON', '==4.04';
requires 'JSON::XS', '==4.03';
requires 'local::lib', '==2.000028';
requires 'Log::Any', '==1.710';
requires 'Log::Any::Adapter', '==1.710';
requires 'Log::Any::For::Std', '==0.05';
requires 'Math::Random::Secure', '==0.080001';
requires 'Mojolicious', '==9.22';
requires 'Mojo::IOLoop::Signal', '==0.003';
requires 'Mojo::Redis', '==3.27';
requires 'Mojo::UserAgent::Cached', '==1.18';
requires 'POSIX', '0';
requires 'Protocol::Redis::XS', '0';
requires 'URI::Encode::XS', '==0.11';
requires 'URI::URL', '==5.10';

13
data/config_sample.json
View File

@@ -2,6 +2,9 @@
# server address
"server" : "redis",
"port" : "6379",
"channels": [
"webapp"
],
# should we fork() and become unix daemon?
"daemonize": 1,
@@ -12,15 +15,15 @@
# unprivileged system user to run bot as
"user" : "nobody",
# messages with commands will begin with this symbol
"csign": "!",
# logs goes there
"log" : "/var/log/aleesa-weba/aleesa-weba.log",
"log" : "/var/log/aleesa-webapp/aleesa-webapp.log",
"loglevel": "notice",
# ditto
"pid" : "/var/run/aleesa-weba/aleesa-weba.pid",
"pid" : "/var/run/aleesa-webapp/aleesa-webapp.pid",
# maximal amount of message forwardings, to avoid endless loops
"forwards_max" : 5,
"openweathermap" : {
"appid": "get_it_on_openweathermap.org"

58
lib/Buni.pm
View File

@@ -1,58 +0,0 @@
package Buni;
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use HTTP::Tiny;
use HTML::TokeParser;
use Log::Any qw ($log);
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 {
$log->warn (sprintf '[WARN] 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:

11
lib/Conf.pm
View File

@@ -1,5 +1,5 @@
package Conf;
# loads config
# Загружает конфиг
use 5.018;
use strict;
@@ -7,6 +7,7 @@ use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Encode qw (encode);
use JSON::XS;
use version; our $VERSION = qw (1.0);
@@ -16,20 +17,16 @@ our @EXPORT_OK = qw (LoadConf);
sub LoadConf {
my $c = 'data/config.json';
open my $CH, '<', $c or die "[FATAL] No conf at $c: $OS_ERROR\n";
my $len = (stat $c) [7];
my $json;
my $len = (stat $c) [7];
my $readlen = read $CH, $json, $len;
$json = encode 'UTF-8', $json;
unless ($readlen) {
close $CH; ## no critic (InputOutput::RequireCheckedSyscalls
die "[FATAL] Unable to read $c: $OS_ERROR\n";
}
if ($readlen != $len) {
close $CH; ## no critic (InputOutput::RequireCheckedSyscalls
die "[FATAL] 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);

124
lib/Drink.pm
View File

@@ -1,124 +0,0 @@
package Drink;
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Encode;
use CHI;
use CHI::Driver::BerkeleyDB;
use DateTime;
use HTTP::Tiny;
use HTML::TokeParser;
use Log::Any qw ($log);
use POSIX qw (strftime);
use 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 {
$log->warn (sprintf '[WARN] Server return status %s with message: %s', $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:

54
lib/Fox.pm
View File

@@ -1,54 +0,0 @@
package Fox;
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use JSON::XS;
use HTTP::Tiny;
use Log::Any qw ($log);
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) {
$log->warn ("[WARN] Unable to decode JSON: $EVAL_ERROR");
} else {
if ($jfox->{image}) {
$jfox->{image} =~ s/\\//xmsg;
$ret = $jfox->{image};
}
}
} else {
$log->warn (sprintf '[WARN] 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:

70
lib/Image.pm
View File

@@ -1,70 +0,0 @@
package Image;
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use 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:

53
lib/Kitty.pm
View File

@@ -1,53 +0,0 @@
package Kitty;
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use JSON::XS;
use HTTP::Tiny;
use Log::Any qw ($log);
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) {
$log->error ("[ERROR] Unable to decode JSON: $EVAL_ERROR");
} else {
if ($jcat->[0]->{url}) {
$ret = $jcat->[0]->{url};
}
}
} else {
$log->error (sprintf '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:

62
lib/Monkeyuser.pm
View File

@@ -1,62 +0,0 @@
package Monkeyuser;
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use HTTP::Tiny;
use HTML::TokeParser;
use Log::Any qw ($log);
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 {
$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:

116
lib/Util.pm
View File

@@ -1,116 +0,0 @@
package 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:

177
lib/Weather.pm
View File

@@ -1,177 +0,0 @@
package 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 Log::Any qw ($log);
use Conf qw (LoadConf);
use 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) {
$log->warn ('[WARN] No appid specified for openweathermap');
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) {
$log->warn ("[WARN] openweathermap returns corrupted json: $EVAL_ERROR");
return undef;
};
} else {
$log->warn (sprintf 'Server return status %s with message: %s', $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:

232
lib/WebApp.pm
View File

@@ -1,109 +1,251 @@
package WebApp;
# общие модули - синтаксис, кодировки итд
# Общие модули - синтаксис, кодировки итд
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
# модули для работы приложения
# Модули для работы приложения
use Data::Dumper;
use Log::Any qw ($log);
use Math::Random::Secure qw (irand);
use Mojo::Redis;
use Mojo::IOLoop;
use Mojo::IOLoop::Signal;
# плагины web-клиентов
use Buni qw (Buni);
# Плагины web-клиентов
use Conf qw (LoadConf);
use Drink qw (Drink);
use Fox qw (Fox);
use Image qw (Rabbit Owl Frog Horse Snail);
use Kitty qw (Kitty);
use Monkeyuser qw (Monkeyuser);
use Weather qw (Weather);
use Xkcd qw (Xkcd);
use WebApp::Client qw (Anek Buni Drink Monkeyuser Kitty Fox Oboobs Obutts Rabbit Owl Frog Horse Snail Xkcd Weather);
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (RunWebApp);
my $c = LoadConf ();
my $fwd_cnt = $c->{'forward_max'} // 5;
# основной парсер
# Основной парсер
my $parse_message = sub {
my $self = shift;
my $m = shift;
my $answer = $m;
my $send_to = $answer->{from};
$answer->{from} = 'webapp';
my $send_to = $m->{plugin};
my $reply;
if (defined $answer->{misc}) {
unless (defined $answer->{misc}->{fwd_cnt}) {
$answer->{misc}->{fwd_cnt} = 1;
} else {
if ($answer->{misc}->{fwd_cnt} > $fwd_cnt) {
$log->error ('Forward loop detected, discarding message.');
$log->debug (Dumper $m);
return;
} else {
$answer->{misc}->{fwd_cnt}++;
}
}
unless (defined $answer->{misc}->{answer}) {
$answer->{misc}->{answer} = 1;
}
unless (defined $answer->{misc}->{csign}) {
$answer->{misc}->{csign} = '!';
}
} else {
$answer->{misc}->{answer} = 1;
$answer->{misc}->{csign} = '!';
$answer->{misc}->{msg_format} = 0;
}
$log->debug ('[DEBUG] Incoming message ' . Dumper($m));
if (substr ($m->{message}, 1) eq 'buni') {
$answer->{message} = Buni ();
$reply = Buni ();
} elsif (substr ($m->{message}, 1) eq 'anek' || substr ($m->{message}, 1) eq 'анек' || substr ($m->{message}, 1) eq 'анекдот') {
if ($m->{plugin} eq 'telegram') {
$reply = "```\n" . Anek () . "\n```";
$answer->{misc}->{msg_format} = 1;
} else {
$reply = Anek ();
}
} elsif (substr ($m->{message}, 1) eq 'cat' || substr ($m->{message}, 1) eq 'кис') {
$answer->{message} = Kitty ();
if ($m->{plugin} eq 'telegram') {
my @cats = ('龴ↀ◡ↀ龴', '=^..^=', '≧◔◡◔≦ ','^ↀᴥↀ^');
my $cat = Kitty ();
$reply = sprintf '[%s](%s)', $cats[irand ($#cats + 1)], $cat;
$answer->{misc}->{msg_format} = 1;
} else {
$reply = Kitty ();
}
} elsif (substr ($m->{message}, 1) eq 'drink' || substr ($m->{message}, 1) eq 'праздник') {
$answer->{message} = Drink ();
$reply = Drink ();
} elsif (substr ($m->{message}, 1) eq 'fox' || substr ($m->{message}, 1) eq 'лис') {
$answer->{message} = Fox ();
if ($m->{plugin} eq 'telegram') {
my $fox = Fox ();
$reply = sprintf '[-^^,--,~](%s)', $fox;
$answer->{misc}->{msg_format} = 1;
} else {
$reply = Fox ();
}
} elsif (substr ($m->{message}, 1) eq 'frog' || substr ($m->{message}, 1) eq 'лягушка') {
$answer->{message} = Frog ();
if ($m->{plugin} eq 'telegram') {
my @art = qw (frog toad лягушка);
my $frog = Frog ();
$reply = sprintf '[%s](%s)', $art [irand ($#art + 1)], $frog;
$answer->{misc}->{msg_format} = 1;
} else {
$reply = Frog ();
}
} elsif (substr ($m->{message}, 1) eq 'horse' || substr ($m->{message}, 1) eq 'лошадь' || substr ($m->{message}, 1) eq 'лошадка') {
$answer->{message} = Horse ();
if ($m->{plugin} eq 'telegram') {
my @art = qw (horse лошадь лошадка);
my $horse = Horse ();
$reply = sprintf '[%s](%s)', $art [irand ($#art + 1)], $horse;
$answer->{misc}->{msg_format} = 1;
} else {
$reply = Horse ();
}
} elsif (substr ($m->{message}, 1) eq 'monkeyuser') {
$answer->{message} = Monkeyuser ();
$reply = Monkeyuser ();
} elsif (substr ($m->{message}, 1) eq 'owl' || substr ($m->{message}, 1) eq 'сова' || substr ($m->{message}, 1) eq 'сыч') {
$answer->{message} = Owl ();
if ($m->{plugin} eq 'telegram') {
my $owl = Owl ();
$reply = sprintf '[{ O v O }](%s)', $owl;
$answer->{misc}->{msg_format} = 1;
} else {
$reply = Owl ();
}
} elsif (substr ($m->{message}, 1) eq 'rabbit' || substr ($m->{message}, 1) eq 'bunny' || substr ($m->{message}, 1) eq 'кролик') {
$answer->{message} = Rabbit ();
if ($m->{plugin} eq 'telegram') {
my $rabbit = Rabbit ();
$reply = sprintf '[(\_/)](%s)', $rabbit;
$answer->{misc}->{msg_format} = 1;
} else {
$reply = Rabbit ();
}
} elsif (substr ($m->{message}, 1) eq 'snail' || substr ($m->{message}, 1) eq 'улитка') {
$answer->{message} = Snail ();
if ($m->{plugin} eq 'telegram') {
my @art = qw ('-'_@_ @╜ @_'-');
my $snail = Snail ();
$reply = sprintf '[%s](%s)', $art [irand ($#art + 1)], $snail;
$answer->{misc}->{msg_format} = 1;
} else {
$reply = Snail ();
}
} elsif (substr ($m->{message}, 1) eq 'xkcd') {
$answer->{message} = Xkcd ();
$reply = Xkcd ();
} elsif (substr ($m->{message}, 1, 2) eq 'w ' || substr ($m->{message}, 1, 2) eq 'п ') {
my $city = substr $m->{message}, 2;
$answer->{message} = Weather ($city);
$reply = Weather ($city);
} elsif (substr ($m->{message}, 1, 8) eq 'weather ' || substr ($m->{message}, 1, 8) eq 'погодка ' || substr ($m->{message}, 1, 8) eq 'погадка ') {
my $city = substr $m->{message}, 9;
$reply = Weather ($city);
} elsif (substr ($m->{message}, 1, 7) eq 'погода ') {
my $city = substr $m->{message}, 8;
$reply = Weather ($city);
} elsif (substr ($m->{message}, 1) eq 'tits' ||
substr ($m->{message}, 1) eq 'boobs' ||
substr ($m->{message}, 1) eq 'tities' ||
substr ($m->{message}, 1) eq 'boobies' ||
substr ($m->{message}, 1) eq 'сиси' ||
substr ($m->{message}, 1) eq 'сисечки') {
if ($m->{plugin} eq 'telegram') {
my @art = ('(. )( .)', '( . Y . )', '(o)(o)', '( @ )( @ )', '(.)(.)');
my $oboobs = Oboobs ();
$reply = sprintf '[%s](%s)', $art [irand ($#art + 1)], $oboobs;
$answer->{misc}->{msg_format} = 1;
} else {
$reply = Oboobs ();
}
} elsif (substr ($m->{message}, 1) eq 'butt' ||
substr ($m->{message}, 1) eq 'booty' ||
substr ($m->{message}, 1) eq 'ass' ||
substr ($m->{message}, 1) eq 'попа' ||
substr ($m->{message}, 1) eq 'попка') {
if ($m->{plugin} eq 'telegram') {
my @art = ('(__(__)', '(_!_)', '(__.__)');
my $obutts = Obutts ();
$reply = sprintf '[%s](%s)', $art [irand ($#art + 1)], $obutts;
$answer->{misc}->{msg_format} = 1;
} else {
$reply = Oboobs ();
}
} else {
$log->info (sprintf 'Unable to process unknown message: %s', $m->{message});
}
if (defined $reply) {
$answer->{message} = $reply;
$log->debug ("[DEBUG] Sending message to channel $send_to " . Dumper ($answer));
$self->json ($send_to)->notify (
$send_to => {
from => $answer->{from},
userid => $answer->{userid},
chatid => $answer->{chatid},
plugin => $answer->{plugin},
message => $answer->{message}
}
$send_to => $answer
);
}
return;
};
my $__signal_handler = sub {
my ($self, $name) = @_;
$log->info ("[INFO] Caught a signal $name");
if (defined $main::pidfile && -f $main::pidfile) {
unlink $main::pidfile;
}
exit 0;
};
# main loop, он же event loop
sub RunWebApp {
$log->info ("[INFO] Connecting to $c->{server}, $c->{port}");
my $redis = Mojo::Redis->new (
sprintf 'redis://%s:%s/1', $c->{server}, $c->{port}
);
$log->info ('[INFO] Registering connection-event callback');
$redis->on (
connection => sub {
my ($r, $connection) = @_;
$log->info ('[INFO] Triggering callback on new client connection');
# Залоггируем ошибку, если соединение внезапно порвалось.
$connection->on (
error => sub {
my ($conn, $error) = @_;
$log->error ("[ERROR] Redis connection error: $error");
return;
}
);
return;
}
);
my $pubsub = $redis->pubsub;
my $sub;
$log->info ('[INFO] Subscribing to redis channels');
$pubsub->listen (
# Вот такая ебическая конструкция для авто-подписывания на все новые каналы.
# Странное ограничение, при котором на шаблон каналов можно подписаться только, подписавшись на каждый из
# каналов. То есть подписка создаётся по запросу. В AnyEvent::Redis подписаться можно сразу на * :(
# Но конкретно в моём случае этот момент неважен, т.к. подразумевается, что каналы будут добавляться, но не
# будут убавляться.
'webapp:*' => sub {
my ($ps, $channel) = @_ ;
foreach my $channel (@{$c->{channels}}) {
$log->debug ("[DEBUG] Subscribing to $channel");
unless (defined $sub->{$channel}) {
$log->info ("Subscribing to $channel");
$sub->{$channel} = $ps->json ($channel)->listen (
$sub->{$channel} = $pubsub->json ($channel)->listen (
$channel => sub { $parse_message->(@_); }
);
}
}
Mojo::IOLoop::Signal->on (
TERM => $__signal_handler,
INT => $__signal_handler
);
do { Mojo::IOLoop->start } until Mojo::IOLoop->is_running;

677
lib/WebApp/Client.pm Normal file
View File

@@ -0,0 +1,677 @@
package WebApp::Client;
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 DateTime;
use Encode;
use HTML::TokeParser;
use JSON::XS;
use Log::Any qw ($log);
use Math::Random::Secure qw (irand);
use Mojo::Log;
use Mojo::UserAgent;
use Mojo::UserAgent::Cached;
use Mojo::Util qw (trim);
use POSIX qw (strftime);
use URI::URL;
use Conf qw (LoadConf);
use WebApp::Client::API::Flickr qw (FlickrByTags);
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (Anek Buni Drink Monkeyuser Kitty Fox Oboobs Obutts Rabbit Owl Frog Horse Snail Xkcd Weather);
my @MONTH = qw (yanvar fevral mart aprel may iyun iyul avgust sentyabr oktyabr noyabr dekabr);
my $c = LoadConf ();
my $cachedir = $c->{cachedir};
sub urlencode {
my $str = shift;
unless (defined $str) {
cluck '[ERROR] Str is undefined';
return '';
}
my $urlobj = url $str;
return $urlobj->as_string;
}
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;
}
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;
}
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;
}
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;
}
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}) {
$ret = $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 = $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}) {
$ret = sprintf 'https://media.oboobs.ru/%s', $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}) {
$ret = sprintf 'http://media.obutts.ru/%s', $jobutts->[0]->{preview};
}
}
} else {
$log->warn (sprintf '[WARN] Obutts server return status %s with message: %s', $r->code, $r->message);
}
return $ret;
}
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 {
my $url = FlickrByTags ('frog,toad,amphibian');
if (defined $url) {
return $url;
} else {
return 'Нету лягушек, все свалили.';
}
}
sub Horse {
my $url = FlickrByTags ('horse,equine,mammal');
if (defined $url) {
return $url;
} else {
return 'Нету коняшек, все разбежались.';
}
}
sub Snail {
my $url = FlickrByTags ('snail,slug');
if (defined $url) {
return $url;
} else {
return 'Нету улиток, все расползлись.';
}
}
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 'Комикс-стрип нарисовать не так-то просто :(';
}
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:

240
lib/Image/Flickr.pm → lib/WebApp/Client/API/Flickr.pm
View File

@@ -1,4 +1,4 @@
package Image::Flickr;
package WebApp::Client::API::Flickr;
use 5.018;
use strict;
@@ -7,18 +7,16 @@ 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 File::Path qw (make_path);
use JSON::XS;
use HTTP::Tiny;
use Log::Any qw ($log);
use Math::Random::Secure qw (irand);
use MIME::Base64;
use SQLite_File;
use Mojo::UserAgent;
use URI::Encode::XS qw (uri_encode);
use Conf qw (LoadConf);
use Util qw (urlencode);
use Data::Dumper;
@@ -27,7 +25,7 @@ use Exporter qw (import);
our @EXPORT_OK = qw (FlickrInit FlickrByTags FlickrByText FlickrTestLogin);
my $c = LoadConf ();
my $dir = $c->{image}->{dir};
my $cachedir = $c->{cachedir};
my $flickr_consumer_key = $c->{image}->{flickr}->{consumer_key};
my $flickr_consumer_secret = $c->{image}->{flickr}->{consumer_secret};
@@ -44,7 +42,7 @@ sub mknonce {
return $nonce;
}
sub flickrSignReq {
sub flickerSignReq {
my %p = @_;
my $string;
my $hmac;
@@ -106,7 +104,7 @@ sub flickrRequestToken {
my $oauth_timestamp = time ();
my $oauth_nonce = mknonce ();
my $oauth_signature = flickrSignReq (
my $oauth_signature = flickerSignReq (
type => 'request_token',
oauth_timestamp => $oauth_timestamp,
oauth_nonce => $oauth_nonce
@@ -121,15 +119,15 @@ sub flickrRequestToken {
uri_encode ($flickr_callback_url)
);
my $http = HTTP::Tiny->new (timeout => 5);
my $r = $http->get ($url);
my $ua = Mojo::UserAgent->new->connect_timeout (5);
my $r = $ua->get ($url)->result;
my %params;
if ($r->{success}) {
if ($r->is_success) {
# they ignore format=json, so...
%params = map {split /=/} split /&/, $r->{content};
%params = map {split /=/} split /&/, $r->body;
} else {
say "Something bad returns from flickr api: $r->{status} $r->{content}"; ## no critic (InputOutput::RequireCheckedSyscalls)
say "Something bad returns from flickr api: $r->code $r->message"; ## no critic (InputOutput::RequireCheckedSyscalls)
}
return %params;
@@ -143,7 +141,7 @@ sub flickrAccessToken {
my $oauth_timestamp = time ();
my $oauth_nonce = mknonce ();
my $oauth_signature = flickrSignReq (
my $oauth_signature = flickerSignReq (
type => 'access_token',
oauth_timestamp => $oauth_timestamp,
oauth_nonce => $oauth_nonce,
@@ -162,15 +160,15 @@ sub flickrAccessToken {
uri_encode ($oauth_signature)
);
my $http = HTTP::Tiny->new (timeout => 5);
my $r = $http->get ($url);
my $ua = Mojo::UserAgent->new->connect_timeout (5);
my $r = $ua->get ($url)->result;
my %params;
if ($r->{success}) {
if ($r->is_success) {
# they ignore format=json
%params = map {split /=/} split /&/, $r->{content};
%params = map {split /=/} split /&/, $r->body;
} else {
say "Something bad returns from flickr api: $r->{status} $r->{content}"; ## no critic (InputOutput::RequireCheckedSyscalls)
say "Something bad returns from flickr api: $r->code $r->message"; ## no critic (InputOutput::RequireCheckedSyscalls)
}
return %params;
@@ -184,13 +182,13 @@ sub flickrAuthorization {
$flickr_request_token,
);
my $http = HTTP::Tiny->new (timeout => 5);
my $r = $http->get ($url);
my $ua = Mojo::UserAgent->new->connect_timeout (5);
my $r = $ua->get ($url)->result;
if ($r->{success}) {
return $r->{url};
if ($r->code == 302) {
return $r->content->headers->location;
} else {
say "Something went wrong: $r->{status} $r->{content}"; ## no critic (InputOutput::RequireCheckedSyscalls)
printf "Something went wrong: %s %s\n", $r->code, $r->message;
return;
}
}
@@ -202,7 +200,7 @@ sub flickrTestLogin {
my $oauth_timestamp = time ();
my $oauth_nonce = mknonce ();
my $oauth_signature = flickrSignReq (
my $oauth_signature = flickerSignReq (
nojsoncallback => 1,
oauth_nonce => $oauth_nonce,
format => 'json',
@@ -225,24 +223,23 @@ sub flickrTestLogin {
uri_encode ($oauth_signature)
);
my $http = HTTP::Tiny->new (timeout => 5);
my $r = $http->get ($url);
my $ua = Mojo::UserAgent->new->connect_timeout (5);
my $r = $ua->get ($url)->result;
if ($r->{success}) {
if ($r->is_success) {
my $response = eval {
my $j = JSON::XS->new->utf8->relaxed;
return $j->decode ($r->{content});
return $r->json;
};
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)
say "Flickr api returns incorrect json: $r->message"; ## no critic (InputOutput::RequireCheckedSyscalls)
return 0;
}
} else {
say "HTTP status code not 200: $r->{status}, $r>{contenr}"; ## no critic (InputOutput::RequireCheckedSyscalls)
say "HTTP status code not 200: $r->code, $r->message"; ## no critic (InputOutput::RequireCheckedSyscalls)
return 0;
}
}
@@ -255,7 +252,7 @@ sub flickrSearchByText {
my $oauth_timestamp = time ();
my $oauth_nonce = mknonce ();
my $oauth_signature = flickrSignReq (
my $oauth_signature = flickerSignReq (
nojsoncallback => 1,
oauth_nonce => $oauth_nonce,
format => 'json',
@@ -283,21 +280,20 @@ sub flickrSearchByText {
uri_encode ($text)
);
my $http = HTTP::Tiny->new (timeout => 5);
my $r = $http->get ($url);
my $ua = Mojo::UserAgent->new->connect_timeout (5);
my $r = $ua->get ($url)->result;
if ($r->{success}) {
if ($r->is_success) {
my $response = eval {
my $j = JSON::XS->new->utf8->relaxed;
return $j->decode ($r->{content});
return $r->json;
};
if (defined $response) {
# lets make another query, this time with random picture
my $page = irand (int $response->{photos}->{total} / 500);
my $page = irand int ($response->{photos}->{total} / 500);
$oauth_timestamp = time ();
$oauth_nonce = mknonce ();
$oauth_signature = flickrSignReq (
$oauth_signature = flickerSignReq (
nojsoncallback => 1,
oauth_nonce => $oauth_nonce,
format => 'json',
@@ -327,31 +323,31 @@ sub flickrSearchByText {
uri_encode ($text)
);
$http = HTTP::Tiny->new (timeout => 5);
$r = $http->get ($url);
$ua = Mojo::UserAgent->new->connect_timeout (5);
$r = $ua->get ($url)->result;
if ($r->{success}) {
if ($r->is_success) {
$response = eval {
my $j = JSON::XS->new->utf8->relaxed;
return $j->decode ($r->{content});
return $r->json;
};
if (defined $response) {
return $response;
} else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
return undef;
}
} else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
return undef;
}
} else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
return undef;
}
} else {
$log->warn ("[WARN] HTTP status code not 200: $r->{status}, $r->{content}");
$log->warn ("[WARN] Flickr api HTTP status code not 200: $r->code, $r->message");
return undef;
}
}
@@ -364,7 +360,7 @@ sub flickrSearchByTags {
my $oauth_timestamp = time ();
my $oauth_nonce = mknonce ();
my $oauth_signature = flickrSignReq (
my $oauth_signature = flickerSignReq (
nojsoncallback => 1,
oauth_nonce => $oauth_nonce,
format => 'json',
@@ -392,13 +388,12 @@ sub flickrSearchByTags {
uri_encode ($tags)
);
my $http = HTTP::Tiny->new (timeout => 5);
my $r = $http->get ($url);
my $ua = Mojo::UserAgent->new->connect_timeout (5);
my $r = $ua->get ($url)->result;
if ($r->{success}) {
if ($r->is_success) {
my $response = eval {
my $j = JSON::XS->new->utf8->relaxed;
return $j->decode ($r->{content});
return $r->json;
};
if (defined $response) {
@@ -406,7 +401,7 @@ sub flickrSearchByTags {
my $page = irand int ($response->{photos}->{total} / 500);
$oauth_timestamp = time ();
$oauth_nonce = mknonce ();
$oauth_signature = flickrSignReq (
$oauth_signature = flickerSignReq (
nojsoncallback => 1,
oauth_nonce => $oauth_nonce,
format => 'json',
@@ -436,117 +431,96 @@ sub flickrSearchByTags {
uri_encode ($tags)
);
$http = HTTP::Tiny->new (timeout => 5);
$r = $http->get ($url);
$ua = Mojo::UserAgent->new->connect_timeout (5);
$r = $ua->get ($url)->result;
if ($r->{success}) {
if ($r->is_success) {
$response = eval {
my $j = JSON::XS->new->utf8->relaxed;
return $j->decode ($r->{content});
return $r->json;
};
if (defined $response) {
return $response;
} else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
return undef;
}
} else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
return undef;
}
} else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
return undef;
}
} else {
$log->warn ("[WARN] HTTP status code not 200: $r->{status}, $r>{content}");
$log->warn ("[WARN] Flickr api HTTP status code not 200: $r->code, $r->message");
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;
};
my $cache = CHI->new (
driver => 'BerkeleyDB',
root_dir => $cachedir,
namespace => __PACKAGE__
);
if (defined $flickr_verifier && $flickr_verifier) {
my $flickr_request_token = $secret{flickr_request_token};
my $flickr_request_token_secret = $secret{flickr_request_token_secret};
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 $backingfile"; ## no critic (InputOutput::RequireCheckedSyscalls)
say 'Please remove verifier settings from config.json and run this script again'; ## no critic (InputOutput::RequireCheckedSyscalls)
untie %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})) {
$secret{flickr_access_token} = $accessToken{oauth_token};
$secret{flickr_access_token_secret} = $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 in %s',
'Access token (%s) and access token secret (%s) are config db',
$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};
# 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)
untie %secret;
return 1;
}
}
}
untie %secret;
return 0;
}
sub FlickrTestLogin {
my $text = shift;
my $backingfile = sprintf '%s/secrets.sqlite', $dir;
my $cache = CHI->new (
driver => 'BerkeleyDB',
root_dir => $cachedir,
namespace => __PACKAGE__
);
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;
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;
@@ -557,23 +531,15 @@ sub FlickrTestLogin {
sub FlickrByTags {
my $text = shift;
my $backingfile = sprintf '%s/secrets.sqlite', $dir;
unless (-d $dir) {
make_path ($dir) or do {
$log->error ("[ERROR] Unable to create $dir: $OS_ERROR");
return 0;
};
}
my $cache = CHI->new (
driver => 'BerkeleyDB',
root_dir => $cachedir,
namespace => __PACKAGE__
);
tie my %secret, 'SQLite_File', $backingfile || do {
$log->error ("[ERROR] Unable to tie to $backingfile: $OS_ERROR");
return 0;
};
my $flickr_access_token = $secret{flickr_access_token};
my $flickr_access_token_secret = $secret{flickr_access_token_secret};
untie %secret;
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
@@ -583,7 +549,7 @@ sub FlickrByTags {
if ($result) {
if (defined ($result->{photos}) && defined ($result->{photos}->{photo})) {
my $item = irand int @{$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;
@@ -598,23 +564,15 @@ sub FlickrByTags {
sub FlickrByText {
my $text = shift;
my $backingfile = sprintf '%s/secrets.sqlite', $dir;
unless (-d $dir) {
make_path ($dir) or do {
$log->error ("[ERROR] Unable to create $dir: $OS_ERROR");
return 0;
};
}
my $cache = CHI->new (
driver => 'BerkeleyDB',
root_dir => $cachedir,
namespace => __PACKAGE__
);
tie my %secret, 'SQLite_File', $backingfile || do {
$log->error ("[ERROR] Unable to tie to $backingfile: $OS_ERROR");
return 0;
};
my $flickr_access_token = $secret{flickr_access_token};
my $flickr_access_token_secret = $secret{flickr_access_token_secret};
untie %secret;
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
@@ -624,7 +582,7 @@ sub FlickrByText {
if ($result) {
if (defined ($result->{photos}) && defined ($result->{photos}->{photo})) {
my $item = irand (int (@{$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;

42
lib/Xkcd.pm
View File

@@ -1,42 +0,0 @@
package 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: