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] [-ControlStructures::ProhibitDeepNests]
# Have to use it, so fuckoff # Have to use it, so fuckoff
[-Variables::ProhibitPackageVars]

122
README
View File

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

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 (); daemonize ();
} elsif ( ! defined ($c->{daemonize})) { } elsif ( ! defined ($C->{daemonize})) {
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', '0';
requires 'Carp'; requires 'CHI', '==0.61';
requires 'CHI'; requires 'CHI::Driver::BerkeleyDB', '==0.05';
requires 'CHI::Driver::BerkeleyDB'; requires 'Cwd::utf8', '==0.011';
requires 'Cwd::utf8'; requires 'DateTime', '==1.55';
requires 'DateTime'; requires 'Digest::HMAC_SHA1', '==1.04';
requires 'DB_File'; requires 'Encode', '==3.16';
requires 'DBI'; requires 'EV', '==4.33';
requires 'DBD::SQLite'; requires 'File::Basename', '0';
requires 'Digest::HMAC_SHA1'; requires 'File::Path', '==2.18';
requires 'Digest::MD5'; requires 'HTML::TokeParser', '==3.76';
requires 'Digest::SHA'; requires 'IO::Socket::SSL', '==2.073';
requires 'Encode'; requires 'JSON', '==4.04';
requires 'EV'; requires 'JSON::XS', '==4.03';
requires 'File::Basename'; requires 'local::lib', '==2.000028';
requires 'File::Path'; requires 'Log::Any', '==1.710';
requires 'Hailo'; requires 'Log::Any::Adapter', '==1.710';
requires 'HTML::TokeParser'; requires 'Log::Any::For::Std', '==0.05';
requires 'HTTP::Tiny'; requires 'Math::Random::Secure', '==0.080001';
requires 'IO::Socket::SSL'; requires 'Mojolicious', '==9.22';
requires 'JSON'; requires 'Mojo::IOLoop::Signal', '==0.003';
requires 'JSON::XS'; requires 'Mojo::Redis', '==3.27';
requires 'List::Util'; requires 'Mojo::UserAgent::Cached', '==1.18';
requires 'local::lib'; requires 'POSIX', '0';
requires 'Log::Any'; requires 'Protocol::Redis::XS', '0';
requires 'Log::Any::Adapter'; requires 'URI::Encode::XS', '==0.11';
requires 'Log::Any::For::Std'; requires 'URI::URL', '==5.10';
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';

25
data/config_sample.json
View File

@@ -1,26 +1,29 @@
{ {
# server address # server address
"server" : "redis", "server" : "redis",
"port" : "6379", "port" : "6379",
"channels": [
"webapp"
],
# should we fork() and become unix daemon? # should we fork() and become unix daemon?
"daemonize": 1, "daemonize": 1,
# where caches go there # where caches go there
"cachedir" : "data/cache", "cachedir" : "data/cache",
# unprivileged system user to run bot as # unprivileged system user to run bot as
"user" : "nobody", "user" : "nobody",
# messages with commands will begin with this symbol # logs goes there
"csign": "!", "log" : "/var/log/aleesa-webapp/aleesa-webapp.log",
# logs goes there
"log" : "/var/log/aleesa-weba/aleesa-weba.log",
"loglevel": "notice", "loglevel": "notice",
# ditto # 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" : { "openweathermap" : {
"appid": "get_it_on_openweathermap.org" "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; package Conf;
# loads config # Загружает конфиг
use 5.018; use 5.018;
use strict; use strict;
@@ -7,6 +7,7 @@ use warnings;
use utf8; use utf8;
use open qw (:std :utf8); use open qw (:std :utf8);
use English qw ( -no_match_vars ); use English qw ( -no_match_vars );
use Encode qw (encode);
use JSON::XS; use JSON::XS;
use version; our $VERSION = qw (1.0); use version; our $VERSION = qw (1.0);
@@ -16,20 +17,16 @@ our @EXPORT_OK = qw (LoadConf);
sub LoadConf { sub LoadConf {
my $c = 'data/config.json'; my $c = 'data/config.json';
open my $CH, '<', $c or die "[FATAL] No conf at $c: $OS_ERROR\n"; open my $CH, '<', $c or die "[FATAL] No conf at $c: $OS_ERROR\n";
my $len = (stat $c) [7];
my $json; my $json;
my $len = (stat $c) [7];
my $readlen = read $CH, $json, $len; my $readlen = read $CH, $json, $len;
$json = encode 'UTF-8', $json;
unless ($readlen) { unless ($readlen) {
close $CH; ## no critic (InputOutput::RequireCheckedSyscalls close $CH; ## no critic (InputOutput::RequireCheckedSyscalls
die "[FATAL] Unable to read $c: $OS_ERROR\n"; 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 close $CH; ## no critic (InputOutput::RequireCheckedSyscalls
my $j = JSON::XS->new->utf8->relaxed; my $j = JSON::XS->new->utf8->relaxed;
return $j->decode ($json); 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:

240
lib/WebApp.pm
View File

@@ -1,109 +1,251 @@
package WebApp; package WebApp;
# общие модули - синтаксис, кодировки итд # Общие модули - синтаксис, кодировки итд
use 5.018; use 5.018;
use strict; use strict;
use warnings; use warnings;
use utf8; use utf8;
use open qw (:std :utf8); use open qw (:std :utf8);
# модули для работы приложения # Модули для работы приложения
use Data::Dumper;
use Log::Any qw ($log); use Log::Any qw ($log);
use Math::Random::Secure qw (irand);
use Mojo::Redis; use Mojo::Redis;
use Mojo::IOLoop; use Mojo::IOLoop;
use Mojo::IOLoop::Signal;
# плагины web-клиентов # Плагины web-клиентов
use Buni qw (Buni);
use Conf qw (LoadConf); use Conf qw (LoadConf);
use Drink qw (Drink); use WebApp::Client qw (Anek Buni Drink Monkeyuser Kitty Fox Oboobs Obutts Rabbit Owl Frog Horse Snail Xkcd Weather);
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 version; our $VERSION = qw (1.0); use version; our $VERSION = qw (1.0);
use Exporter qw (import); use Exporter qw (import);
our @EXPORT_OK = qw (RunWebApp); our @EXPORT_OK = qw (RunWebApp);
my $c = LoadConf (); my $c = LoadConf ();
my $fwd_cnt = $c->{'forward_max'} // 5;
# основной парсер # Основной парсер
my $parse_message = sub { my $parse_message = sub {
my $self = shift; my $self = shift;
my $m = shift; my $m = shift;
my $answer = $m; 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') { 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 'кис') { } 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 'праздник') { } 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 'лис') { } 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 'лягушка') { } 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 'лошадка') { } 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') { } 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 'сыч') { } 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 'кролик') { } 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 'улитка') { } 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') { } 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 'п ') { } elsif (substr ($m->{message}, 1, 2) eq 'w ' || substr ($m->{message}, 1, 2) eq 'п ') {
my $city = substr $m->{message}, 2; 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 { } else {
$log->info (sprintf 'Unable to process unknown message: %s', $m->{message}); $log->info (sprintf 'Unable to process unknown message: %s', $m->{message});
} }
$self->json ($send_to)->notify ( if (defined $reply) {
$send_to => { $answer->{message} = $reply;
from => $answer->{from}, $log->debug ("[DEBUG] Sending message to channel $send_to " . Dumper ($answer));
userid => $answer->{userid},
chatid => $answer->{chatid}, $self->json ($send_to)->notify (
plugin => $answer->{plugin}, $send_to => $answer
message => $answer->{message} );
} }
);
return; 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 # main loop, он же event loop
sub RunWebApp { sub RunWebApp {
$log->info ("[INFO] Connecting to $c->{server}, $c->{port}");
my $redis = Mojo::Redis->new ( my $redis = Mojo::Redis->new (
sprintf 'redis://%s:%s/1', $c->{server}, $c->{port} 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 $pubsub = $redis->pubsub;
my $sub; my $sub;
$log->info ('[INFO] Subscribing to redis channels');
$pubsub->listen ( foreach my $channel (@{$c->{channels}}) {
# Вот такая ебическая конструкция для авто-подписывания на все новые каналы. $log->debug ("[DEBUG] Subscribing to $channel");
# Странное ограничение, при котором на шаблон каналов можно подписаться только, подписавшись на каждый из
# каналов. То есть подписка создаётся по запросу. В AnyEvent::Redis подписаться можно сразу на * :(
# Но конкретно в моём случае этот момент неважен, т.к. подразумевается, что каналы будут добавляться, но не
# будут убавляться.
'webapp:*' => sub {
my ($ps, $channel) = @_ ;
unless (defined $sub->{$channel}) { $sub->{$channel} = $pubsub->json ($channel)->listen (
$log->info ("Subscribing to $channel"); $channel => sub { $parse_message->(@_); }
);
}
$sub->{$channel} = $ps->json ($channel)->listen ( Mojo::IOLoop::Signal->on (
$channel => sub { $parse_message->(@_); } TERM => $__signal_handler,
); INT => $__signal_handler
}
}
); );
do { Mojo::IOLoop->start } until Mojo::IOLoop->is_running; 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 5.018;
use strict; use strict;
@@ -7,18 +7,16 @@ use utf8;
use open qw (:std :utf8); use open qw (:std :utf8);
use English qw ( -no_match_vars ); use English qw ( -no_match_vars );
use Carp qw (cluck); use Carp qw (cluck);
use CHI;
use CHI::Driver::BerkeleyDB;
use Digest::HMAC_SHA1 qw (hmac_sha1); 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 Log::Any qw ($log);
use Math::Random::Secure qw (irand); use Math::Random::Secure qw (irand);
use MIME::Base64; use MIME::Base64;
use SQLite_File; use Mojo::UserAgent;
use URI::Encode::XS qw (uri_encode); use URI::Encode::XS qw (uri_encode);
use Conf qw (LoadConf); use Conf qw (LoadConf);
use Util qw (urlencode);
use Data::Dumper; use Data::Dumper;
@@ -27,7 +25,7 @@ use Exporter qw (import);
our @EXPORT_OK = qw (FlickrInit FlickrByTags FlickrByText FlickrTestLogin); our @EXPORT_OK = qw (FlickrInit FlickrByTags FlickrByText FlickrTestLogin);
my $c = LoadConf (); my $c = LoadConf ();
my $dir = $c->{image}->{dir}; my $cachedir = $c->{cachedir};
my $flickr_consumer_key = $c->{image}->{flickr}->{consumer_key}; my $flickr_consumer_key = $c->{image}->{flickr}->{consumer_key};
my $flickr_consumer_secret = $c->{image}->{flickr}->{consumer_secret}; my $flickr_consumer_secret = $c->{image}->{flickr}->{consumer_secret};
@@ -44,7 +42,7 @@ sub mknonce {
return $nonce; return $nonce;
} }
sub flickrSignReq { sub flickerSignReq {
my %p = @_; my %p = @_;
my $string; my $string;
my $hmac; my $hmac;
@@ -106,7 +104,7 @@ sub flickrRequestToken {
my $oauth_timestamp = time (); my $oauth_timestamp = time ();
my $oauth_nonce = mknonce (); my $oauth_nonce = mknonce ();
my $oauth_signature = flickrSignReq ( my $oauth_signature = flickerSignReq (
type => 'request_token', type => 'request_token',
oauth_timestamp => $oauth_timestamp, oauth_timestamp => $oauth_timestamp,
oauth_nonce => $oauth_nonce oauth_nonce => $oauth_nonce
@@ -121,15 +119,15 @@ sub flickrRequestToken {
uri_encode ($flickr_callback_url) uri_encode ($flickr_callback_url)
); );
my $http = HTTP::Tiny->new (timeout => 5); my $ua = Mojo::UserAgent->new->connect_timeout (5);
my $r = $http->get ($url); my $r = $ua->get ($url)->result;
my %params; my %params;
if ($r->{success}) { if ($r->is_success) {
# they ignore format=json, so... # they ignore format=json, so...
%params = map {split /=/} split /&/, $r->{content}; %params = map {split /=/} split /&/, $r->body;
} else { } 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; return %params;
@@ -143,7 +141,7 @@ sub flickrAccessToken {
my $oauth_timestamp = time (); my $oauth_timestamp = time ();
my $oauth_nonce = mknonce (); my $oauth_nonce = mknonce ();
my $oauth_signature = flickrSignReq ( my $oauth_signature = flickerSignReq (
type => 'access_token', type => 'access_token',
oauth_timestamp => $oauth_timestamp, oauth_timestamp => $oauth_timestamp,
oauth_nonce => $oauth_nonce, oauth_nonce => $oauth_nonce,
@@ -162,15 +160,15 @@ sub flickrAccessToken {
uri_encode ($oauth_signature) uri_encode ($oauth_signature)
); );
my $http = HTTP::Tiny->new (timeout => 5); my $ua = Mojo::UserAgent->new->connect_timeout (5);
my $r = $http->get ($url); my $r = $ua->get ($url)->result;
my %params; my %params;
if ($r->{success}) { if ($r->is_success) {
# they ignore format=json # they ignore format=json
%params = map {split /=/} split /&/, $r->{content}; %params = map {split /=/} split /&/, $r->body;
} else { } 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; return %params;
@@ -184,13 +182,13 @@ sub flickrAuthorization {
$flickr_request_token, $flickr_request_token,
); );
my $http = HTTP::Tiny->new (timeout => 5); my $ua = Mojo::UserAgent->new->connect_timeout (5);
my $r = $http->get ($url); my $r = $ua->get ($url)->result;
if ($r->{success}) { if ($r->code == 302) {
return $r->{url}; return $r->content->headers->location;
} else { } 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; return;
} }
} }
@@ -202,7 +200,7 @@ sub flickrTestLogin {
my $oauth_timestamp = time (); my $oauth_timestamp = time ();
my $oauth_nonce = mknonce (); my $oauth_nonce = mknonce ();
my $oauth_signature = flickrSignReq ( my $oauth_signature = flickerSignReq (
nojsoncallback => 1, nojsoncallback => 1,
oauth_nonce => $oauth_nonce, oauth_nonce => $oauth_nonce,
format => 'json', format => 'json',
@@ -225,24 +223,23 @@ sub flickrTestLogin {
uri_encode ($oauth_signature) uri_encode ($oauth_signature)
); );
my $http = HTTP::Tiny->new (timeout => 5); my $ua = Mojo::UserAgent->new->connect_timeout (5);
my $r = $http->get ($url); my $r = $ua->get ($url)->result;
if ($r->{success}) { if ($r->is_success) {
my $response = eval { my $response = eval {
my $j = JSON::XS->new->utf8->relaxed; return $r->json;
return $j->decode ($r->{content});
}; };
if (defined $response) { if (defined $response) {
say Dumper $response; ## no critic (InputOutput::RequireCheckedSyscalls) say Dumper $response; ## no critic (InputOutput::RequireCheckedSyscalls)
return 1; return 1;
} else { } 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; return 0;
} }
} else { } 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; return 0;
} }
} }
@@ -255,7 +252,7 @@ sub flickrSearchByText {
my $oauth_timestamp = time (); my $oauth_timestamp = time ();
my $oauth_nonce = mknonce (); my $oauth_nonce = mknonce ();
my $oauth_signature = flickrSignReq ( my $oauth_signature = flickerSignReq (
nojsoncallback => 1, nojsoncallback => 1,
oauth_nonce => $oauth_nonce, oauth_nonce => $oauth_nonce,
format => 'json', format => 'json',
@@ -283,21 +280,20 @@ sub flickrSearchByText {
uri_encode ($text) uri_encode ($text)
); );
my $http = HTTP::Tiny->new (timeout => 5); my $ua = Mojo::UserAgent->new->connect_timeout (5);
my $r = $http->get ($url); my $r = $ua->get ($url)->result;
if ($r->{success}) { if ($r->is_success) {
my $response = eval { my $response = eval {
my $j = JSON::XS->new->utf8->relaxed; return $r->json;
return $j->decode ($r->{content});
}; };
if (defined $response) { if (defined $response) {
# lets make another query, this time with random picture # 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_timestamp = time ();
$oauth_nonce = mknonce (); $oauth_nonce = mknonce ();
$oauth_signature = flickrSignReq ( $oauth_signature = flickerSignReq (
nojsoncallback => 1, nojsoncallback => 1,
oauth_nonce => $oauth_nonce, oauth_nonce => $oauth_nonce,
format => 'json', format => 'json',
@@ -327,31 +323,31 @@ sub flickrSearchByText {
uri_encode ($text) uri_encode ($text)
); );
$http = HTTP::Tiny->new (timeout => 5); $ua = Mojo::UserAgent->new->connect_timeout (5);
$r = $http->get ($url); $r = $ua->get ($url)->result;
if ($r->{success}) {
if ($r->is_success) {
$response = eval { $response = eval {
my $j = JSON::XS->new->utf8->relaxed; return $r->json;
return $j->decode ($r->{content});
}; };
if (defined $response) { if (defined $response) {
return $response; return $response;
} else { } else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}"); $log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
return undef; return undef;
} }
} else { } else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}"); $log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
return undef; return undef;
} }
} else { } else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}"); $log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
return undef; return undef;
} }
} else { } 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; return undef;
} }
} }
@@ -364,7 +360,7 @@ sub flickrSearchByTags {
my $oauth_timestamp = time (); my $oauth_timestamp = time ();
my $oauth_nonce = mknonce (); my $oauth_nonce = mknonce ();
my $oauth_signature = flickrSignReq ( my $oauth_signature = flickerSignReq (
nojsoncallback => 1, nojsoncallback => 1,
oauth_nonce => $oauth_nonce, oauth_nonce => $oauth_nonce,
format => 'json', format => 'json',
@@ -392,13 +388,12 @@ sub flickrSearchByTags {
uri_encode ($tags) uri_encode ($tags)
); );
my $http = HTTP::Tiny->new (timeout => 5); my $ua = Mojo::UserAgent->new->connect_timeout (5);
my $r = $http->get ($url); my $r = $ua->get ($url)->result;
if ($r->{success}) { if ($r->is_success) {
my $response = eval { my $response = eval {
my $j = JSON::XS->new->utf8->relaxed; return $r->json;
return $j->decode ($r->{content});
}; };
if (defined $response) { if (defined $response) {
@@ -406,7 +401,7 @@ sub flickrSearchByTags {
my $page = irand int ($response->{photos}->{total} / 500); my $page = irand int ($response->{photos}->{total} / 500);
$oauth_timestamp = time (); $oauth_timestamp = time ();
$oauth_nonce = mknonce (); $oauth_nonce = mknonce ();
$oauth_signature = flickrSignReq ( $oauth_signature = flickerSignReq (
nojsoncallback => 1, nojsoncallback => 1,
oauth_nonce => $oauth_nonce, oauth_nonce => $oauth_nonce,
format => 'json', format => 'json',
@@ -436,117 +431,96 @@ sub flickrSearchByTags {
uri_encode ($tags) uri_encode ($tags)
); );
$http = HTTP::Tiny->new (timeout => 5); $ua = Mojo::UserAgent->new->connect_timeout (5);
$r = $http->get ($url); $r = $ua->get ($url)->result;
if ($r->{success}) { if ($r->is_success) {
$response = eval { $response = eval {
my $j = JSON::XS->new->utf8->relaxed; return $r->json;
return $j->decode ($r->{content});
}; };
if (defined $response) { if (defined $response) {
return $response; return $response;
} else { } else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}"); $log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
return undef; return undef;
} }
} else { } else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}"); $log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
return undef; return undef;
} }
} else { } else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}"); $log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
return undef; return undef;
} }
} else { } 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; return undef;
} }
} }
sub FlickrInit { sub FlickrInit {
my $backingfile = sprintf '%s/secrets.sqlite', $dir; my $cache = CHI->new (
driver => 'BerkeleyDB',
unless (-d $dir) { root_dir => $cachedir,
make_path ($dir) or do { namespace => __PACKAGE__
say "Unable to create $dir: $OS_ERROR"; ## no critic (InputOutput::RequireCheckedSyscalls) );
return 0;
};
}
tie my %secret, 'SQLite_File', $backingfile || do {
say "[ERROR] Unable to tie to $backingfile: $OS_ERROR"; ## no critic (InputOutput::RequireCheckedSyscalls)
return 0;
};
if (defined $flickr_verifier && $flickr_verifier) { if (defined $flickr_verifier && $flickr_verifier) {
my $flickr_request_token = $secret{flickr_request_token}; my $flickr_request_token = $cache->get ('flickr_request_token');
my $flickr_request_token_secret = $secret{flickr_request_token_secret}; my $flickr_request_token_secret = $cache->get ('flickr_request_token_secret');
unless (defined $flickr_request_token || defined $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 '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) say 'Please remove verifier settings from config.json and run this script again.'; ## no critic (InputOutput::RequireCheckedSyscalls)
untie %secret;
return 0; return 0;
} }
my %accessToken = flickrAccessToken ($flickr_request_token, $flickr_request_token_secret, $flickr_verifier); my %accessToken = flickrAccessToken ($flickr_request_token, $flickr_request_token_secret, $flickr_verifier);
if (defined ($accessToken{oauth_token}) && defined ($accessToken{oauth_token_secret})) { if (defined ($accessToken{oauth_token}) && defined ($accessToken{oauth_token_secret})) {
$secret{flickr_access_token} = $accessToken{oauth_token}; # TODO: check set
$secret{flickr_access_token_secret} = $accessToken{oauth_token_secret}; $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) 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},
$accessToken{oauth_token_secret}, $accessToken{oauth_token_secret},
$backingfile
); );
untie %secret;
return 1; return 1;
} }
} else { } else {
my %req = flickrRequestToken (); my %req = flickrRequestToken ();
if (defined ($req{oauth_token}) && defined ($req{oauth_token_secret}) && defined ($req{oauth_token})) { if (defined ($req{oauth_token}) && defined ($req{oauth_token_secret}) && defined ($req{oauth_token})) {
$secret{flickr_request_token} = $req{oauth_token}; # TODO: check set
$secret{flickr_request_token_secret} = $req{oauth_token_secret}; $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}); my $confirm_url = flickrAuthorization ($req{oauth_token});
if (defined $confirm_url) { 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 "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 '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) say 'Note that you should be logged off from flickr account.'; ## no critic (InputOutput::RequireCheckedSyscalls)
untie %secret;
return 1; return 1;
} }
} }
} }
untie %secret;
return 0; return 0;
} }
sub FlickrTestLogin { sub FlickrTestLogin {
my $text = shift; my $text = shift;
my $backingfile = sprintf '%s/secrets.sqlite', $dir; my $cache = CHI->new (
driver => 'BerkeleyDB',
root_dir => $cachedir,
namespace => __PACKAGE__
);
unless (-d $dir) { my $flickr_access_token = $cache->get ('flickr_access_token');
make_path ($dir) or do { my $flickr_access_token_secret = $cache->get ('flickr_access_token_secret');
say "Unable to create $dir: $OS_ERROR"; ## no critic (InputOutput::RequireCheckedSyscalls)
return 0;
};
}
tie my %secret, 'SQLite_File', $backingfile || do {
say "Unable to tie to $backingfile: $OS_ERROR"; ## no critic (InputOutput::RequireCheckedSyscalls)
return 0;
};
my $flickr_access_token = $secret{flickr_access_token};
my $flickr_access_token_secret = $secret{flickr_access_token_secret};
untie %secret;
if (flickrTestLogin ($flickr_access_token, $flickr_access_token_secret)) { if (flickrTestLogin ($flickr_access_token, $flickr_access_token_secret)) {
return 1; return 1;
@@ -557,23 +531,15 @@ sub FlickrTestLogin {
sub FlickrByTags { sub FlickrByTags {
my $text = shift; my $text = shift;
my $backingfile = sprintf '%s/secrets.sqlite', $dir;
unless (-d $dir) { my $cache = CHI->new (
make_path ($dir) or do { driver => 'BerkeleyDB',
$log->error ("[ERROR] Unable to create $dir: $OS_ERROR"); root_dir => $cachedir,
return 0; namespace => __PACKAGE__
}; );
}
tie my %secret, 'SQLite_File', $backingfile || do { my $flickr_access_token = $cache->get ('flickr_access_token');
$log->error ("[ERROR] Unable to tie to $backingfile: $OS_ERROR"); my $flickr_access_token_secret = $cache->get ('flickr_access_token_secret');
return 0;
};
my $flickr_access_token = $secret{flickr_access_token};
my $flickr_access_token_secret = $secret{flickr_access_token_secret};
untie %secret;
# NB: I honestly query random page (among number of pages) of results from api, but always got first page, # 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 # 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 ($result) {
if (defined ($result->{photos}) && defined ($result->{photos}->{photo})) { 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 = ${$result->{photos}->{photo}}[$item];
$item = sprintf 'https://live.staticflickr.com/%s/%s_%s_z.jpg', $item->{server}, $item->{id}, $item->{secret}; $item = sprintf 'https://live.staticflickr.com/%s/%s_%s_z.jpg', $item->{server}, $item->{id}, $item->{secret};
return $item; return $item;
@@ -598,23 +564,15 @@ sub FlickrByTags {
sub FlickrByText { sub FlickrByText {
my $text = shift; my $text = shift;
my $backingfile = sprintf '%s/secrets.sqlite', $dir;
unless (-d $dir) { my $cache = CHI->new (
make_path ($dir) or do { driver => 'BerkeleyDB',
$log->error ("[ERROR] Unable to create $dir: $OS_ERROR"); root_dir => $cachedir,
return 0; namespace => __PACKAGE__
}; );
}
tie my %secret, 'SQLite_File', $backingfile || do { my $flickr_access_token = $cache->get ('flickr_access_token');
$log->error ("[ERROR] Unable to tie to $backingfile: $OS_ERROR"); my $flickr_access_token_secret = $cache->get ('flickr_access_token_secret');
return 0;
};
my $flickr_access_token = $secret{flickr_access_token};
my $flickr_access_token_secret = $secret{flickr_access_token_secret};
untie %secret;
# NB: I honestly query random page (among number of pages) of results from api, but always got first page, # 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 # 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 ($result) {
if (defined ($result->{photos}) && defined ($result->{photos}->{photo})) { 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 = ${$result->{photos}->{photo}}[$item];
$item = sprintf 'https://live.staticflickr.com/%s/%s_%s_z.jpg', $item->{server}, $item->{id}, $item->{secret}; $item = sprintf 'https://live.staticflickr.com/%s/%s_%s_z.jpg', $item->{server}, $item->{id}, $item->{secret};
return $item; 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: