From c44ab2376b8af96e3765df0357d99575f97db024 Mon Sep 17 00:00:00 2001 From: eleksir Date: Sat, 1 Jan 2022 19:23:40 +0300 Subject: [PATCH] Prepare for first run --- .perlcriticrc | 1 + README | 122 ++-- bin/{aleesa-weba => aleesa-webapp} | 4 +- bin/flickr_init.pl | 29 + bin/test-pub.pl | 49 -- bin/test-sub.pl | 53 -- bin/test.pl | 88 --- contrib/aleesa-webapp.openrc | 11 + cpanfile | 63 +- data/config_sample.json | 25 +- lib/Buni.pm | 58 -- lib/Conf.pm | 11 +- lib/Drink.pm | 124 ---- lib/Fox.pm | 54 -- lib/Image.pm | 70 --- lib/Kitty.pm | 53 -- lib/Monkeyuser.pm | 62 -- lib/Util.pm | 116 ---- lib/Weather.pm | 177 ------ lib/WebApp.pm | 240 ++++++-- lib/WebApp/Client.pm | 677 +++++++++++++++++++++ lib/{Image => WebApp/Client/API}/Flickr.pm | 240 +++----- lib/Xkcd.pm | 42 -- 23 files changed, 1093 insertions(+), 1276 deletions(-) rename bin/{aleesa-weba => aleesa-webapp} (97%) create mode 100644 bin/flickr_init.pl delete mode 100755 bin/test-pub.pl delete mode 100755 bin/test-sub.pl delete mode 100755 bin/test.pl create mode 100644 contrib/aleesa-webapp.openrc delete mode 100644 lib/Buni.pm delete mode 100644 lib/Drink.pm delete mode 100644 lib/Fox.pm delete mode 100644 lib/Image.pm delete mode 100644 lib/Kitty.pm delete mode 100644 lib/Monkeyuser.pm delete mode 100644 lib/Util.pm delete mode 100644 lib/Weather.pm create mode 100644 lib/WebApp/Client.pm rename lib/{Image => WebApp/Client/API}/Flickr.pm (72%) delete mode 100644 lib/Xkcd.pm diff --git a/.perlcriticrc b/.perlcriticrc index 41f004d..1f9bb32 100644 --- a/.perlcriticrc +++ b/.perlcriticrc @@ -93,3 +93,4 @@ lib_sections = NAME | VERSION | DESCRIPTION | AUTHOR | LICENSE AND COPYRIGHT [-ControlStructures::ProhibitDeepNests] # Have to use it, so fuckoff +[-Variables::ProhibitPackageVars] diff --git a/README b/README index 727ae9e..1367de4 100644 --- a/README +++ b/README @@ -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 diff --git a/bin/aleesa-weba b/bin/aleesa-webapp similarity index 97% rename from bin/aleesa-weba rename to bin/aleesa-webapp index ac8e14c..52f270c 100755 --- a/bin/aleesa-weba +++ b/bin/aleesa-webapp @@ -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 (); } diff --git a/bin/flickr_init.pl b/bin/flickr_init.pl new file mode 100644 index 0000000..d54e409 --- /dev/null +++ b/bin/flickr_init.pl @@ -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; +} diff --git a/bin/test-pub.pl b/bin/test-pub.pl deleted file mode 100755 index a8e6195..0000000 --- a/bin/test-pub.pl +++ /dev/null @@ -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; diff --git a/bin/test-sub.pl b/bin/test-sub.pl deleted file mode 100755 index d0608ee..0000000 --- a/bin/test-sub.pl +++ /dev/null @@ -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; diff --git a/bin/test.pl b/bin/test.pl deleted file mode 100755 index bbfeffd..0000000 --- a/bin/test.pl +++ /dev/null @@ -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; diff --git a/contrib/aleesa-webapp.openrc b/contrib/aleesa-webapp.openrc new file mode 100644 index 0000000..751365a --- /dev/null +++ b/contrib/aleesa-webapp.openrc @@ -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 +} diff --git a/cpanfile b/cpanfile index 7834965..d59b9b8 100644 --- a/cpanfile +++ b/cpanfile @@ -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'; diff --git a/data/config_sample.json b/data/config_sample.json index 517003d..60d13c5 100644 --- a/data/config_sample.json +++ b/data/config_sample.json @@ -1,26 +1,29 @@ { -# server address + # server address "server" : "redis", "port" : "6379", + "channels": [ + "webapp" + ], -# should we fork() and become unix daemon? + # should we fork() and become unix daemon? "daemonize": 1, -# where caches go there + # where caches go there "cachedir" : "data/cache", -# unprivileged system user to run bot as + # 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", + # logs goes there + "log" : "/var/log/aleesa-webapp/aleesa-webapp.log", "loglevel": "notice", -# ditto - "pid" : "/var/run/aleesa-weba/aleesa-weba.pid", + # ditto + "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" diff --git a/lib/Buni.pm b/lib/Buni.pm deleted file mode 100644 index 5fee90a..0000000 --- a/lib/Buni.pm +++ /dev/null @@ -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: diff --git a/lib/Conf.pm b/lib/Conf.pm index 38f8860..1154f0e 100644 --- a/lib/Conf.pm +++ b/lib/Conf.pm @@ -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); diff --git a/lib/Drink.pm b/lib/Drink.pm deleted file mode 100644 index a084770..0000000 --- a/lib/Drink.pm +++ /dev/null @@ -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: diff --git a/lib/Fox.pm b/lib/Fox.pm deleted file mode 100644 index f0997fb..0000000 --- a/lib/Fox.pm +++ /dev/null @@ -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: diff --git a/lib/Image.pm b/lib/Image.pm deleted file mode 100644 index 6596c90..0000000 --- a/lib/Image.pm +++ /dev/null @@ -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: diff --git a/lib/Kitty.pm b/lib/Kitty.pm deleted file mode 100644 index a47a130..0000000 --- a/lib/Kitty.pm +++ /dev/null @@ -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: diff --git a/lib/Monkeyuser.pm b/lib/Monkeyuser.pm deleted file mode 100644 index fa2f034..0000000 --- a/lib/Monkeyuser.pm +++ /dev/null @@ -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: diff --git a/lib/Util.pm b/lib/Util.pm deleted file mode 100644 index c51f0b2..0000000 --- a/lib/Util.pm +++ /dev/null @@ -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: diff --git a/lib/Weather.pm b/lib/Weather.pm deleted file mode 100644 index 5176a63..0000000 --- a/lib/Weather.pm +++ /dev/null @@ -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: diff --git a/lib/WebApp.pm b/lib/WebApp.pm index f434193..395f2c0 100644 --- a/lib/WebApp.pm +++ b/lib/WebApp.pm @@ -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}); } - $self->json ($send_to)->notify ( - $send_to => { - from => $answer->{from}, - userid => $answer->{userid}, - chatid => $answer->{chatid}, - plugin => $answer->{plugin}, - message => $answer->{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 => $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} = $pubsub->json ($channel)->listen ( + $channel => sub { $parse_message->(@_); } + ); + } - $sub->{$channel} = $ps->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; diff --git a/lib/WebApp/Client.pm b/lib/WebApp/Client.pm new file mode 100644 index 0000000..516feaa --- /dev/null +++ b/lib/WebApp/Client.pm @@ -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 /
/, $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: diff --git a/lib/Image/Flickr.pm b/lib/WebApp/Client/API/Flickr.pm similarity index 72% rename from lib/Image/Flickr.pm rename to lib/WebApp/Client/API/Flickr.pm index aa5401b..6eadc65 100644 --- a/lib/Image/Flickr.pm +++ b/lib/WebApp/Client/API/Flickr.pm @@ -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; diff --git a/lib/Xkcd.pm b/lib/Xkcd.pm deleted file mode 100644 index 1515bfa..0000000 --- a/lib/Xkcd.pm +++ /dev/null @@ -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: