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

Compare commits

base: aleesa-bot:v1.0
Branches Tags
aleesa-bot:master
aleesa-bot:v1.6 aleesa-bot:v1.5 aleesa-bot:v1.4 aleesa-bot:v1.3 aleesa-bot:v1.2 aleesa-bot:v1.1 aleesa-bot:v1.0
...
compare: aleesa-bot:v1.6
Branches Tags
aleesa-bot:master
aleesa-bot:v1.6 aleesa-bot:v1.5 aleesa-bot:v1.4 aleesa-bot:v1.3 aleesa-bot:v1.2 aleesa-bot:v1.1 aleesa-bot:v1.0

14 Commits
v1.0 ... v1.6

Author SHA1 Message Date
eleksir
f25a4d9ea3 Fix redis message processing, duh 2022-06-21 23:14:01 +03:00
eleksir
3d6be5ae04 Fix !drink for newer perl, also delete unused/obsolete code 2022-06-21 23:00:37 +03:00
eleksir
4c6a1ea4cd Bump version of Mojolicious 9.24 -> 9.26 2022-06-21 22:58:21 +03:00
eleksir
a891c7ed6f Fix !drink command, kind of 2022-05-25 20:40:14 +03:00
eleksir
0daaa6f568 Update cpanfile: bump Mojolicious version 9.22 -> 9.24, drop Protocol::Redis::XS 2022-04-24 02:06:44 +03:00
eleksir
209c9f1ad7 Use less substrs, more deeply tidy incoming json data 2022-04-18 17:24:14 +03:00
eleksir
44a22a3382 Fix a bit code formatting in Client.pm 2022-04-18 17:22:56 +03:00
eleksir
b6a4aaa4c1 Fix handling formating for telegram 2022-04-17 17:09:53 +03:00
eleksir
6b78eb7c1f Add some perlcritic pilicies 2022-04-04 23:05:49 +03:00
eleksir
b9af01728d Fix mistake in exported Conf module name 2022-02-19 16:09:11 +03:00
eleksir
0e9159be0d Update README 2022-02-19 15:48:44 +03:00
eleksir
f13b7d78ed Remove TODO 2022-02-19 15:46:10 +03:00
eleksir
f96e74725d More critic! 2022-02-19 15:44:50 +03:00
eleksir
6b115a63e4 Use 1 of 31 ua-strings for !drink, fix/update README 2022-02-08 20:49:12 +03:00
11 changed files with 368 additions and 202 deletions
Expand all files Collapse all files

38
.perlcriticrc
View File

@@ -1,4 +1,19 @@
#!/usr/bin/env perlcritic #!/usr/bin/env perlcritic
# Задействованные модули критика:
#
# Perl::Critic::More
# Perl::Critic::Pulp
# Perl::Critic::TooMuchCode
# Perl::Critic::Lax
# Perl::Critic::CognitiveComplexity
# Perl::Critic::Policy::CompileTime
# Perl::Critic::Policy::ProhibitImplicitImport
# Perl::Critic::Policy::Dynamic::NoIndirect
# Perl::Critic::StricterSubs
# Perl::Critic::Policy::ProhibitImplicitImport
# Perl::Critic::Policy::CodeLayout::RequireUseUTF8
severity = 5 severity = 5
verbose = 8 verbose = 8
@@ -94,3 +109,26 @@ lib_sections = NAME | VERSION | DESCRIPTION | AUTHOR | LICENSE AND COPYRIGHT
# Have to use it, so fuckoff # Have to use it, so fuckoff
[-Variables::ProhibitPackageVars] [-Variables::ProhibitPackageVars]
[-Miscellanea::ProhibitUnrestrictedNoCritic]
[-Editor::RequireEmacsFileVariables]
[-CodeLayout::RequireASCII]
[-TooMuchCode::ProhibitDuplicateLiteral]
[-ValuesAndExpressions::RequireConstantOnLeftSideOfEquality]
[-Lax::RequireConstantOnLeftSideOfEquality::ExceptEq]
[-TooMuchCode::ProhibitUnnecessaryUTF8Pragma]
[-ErrorHandling::RequireUseOfExceptions]
[-Lax::ProhibitEmptyQuotes::ExceptAsFallback]
[-ValuesAndExpressions::RestrictLongStrings]
[-TooMuchCode::ProhibitLargeBlock]
# read my lips: fuck off

11
README
View File

@@ -7,7 +7,7 @@ aleesa-webapp
----------------------------------------------------------------------------------------------------------------------- -----------------------------------------------------------------------------------------------------------------------
Клиент подписан на на redis-канал webapp. В этот канал пишет другой демоночек - aleesa-misc. Клиент подписан на на redis-канал webapp. В этот канал пишет другой демоночек - aleesa-misc.
Формат протокола Формат протокола общения по redis pub-sub - см README от aleesa-misc.
Плагин для работы с flickr Плагин для работы с flickr
@@ -46,6 +46,12 @@ https://home.openweathermap.org/api_keys . Free plan предлагает всё
Когда api key будет создан, его нужно вписать в config.json в секцию openweathermap в качестве appid. На этом всё. Когда api key будет создан, его нужно вписать в config.json в секцию openweathermap в качестве appid. На этом всё.
Список строк UserAgent для модуля Drink
-----------------------------------------------------------------------------------------------------------------------
На сайте https://kakoysegodnyaprazdnik.ru/ умеют банить по useragent-у чем-то им не угодил UA от Mojo::Client. Пришлось
прикрутить список из 31 штуки Browser UserAgent string, по одному на каждый день недели.
Как это запустить? Как это запустить?
----------------------------------------------------------------------------------------------------------------------- -----------------------------------------------------------------------------------------------------------------------
Понадобится perl, cpanm и local::lib, а также несколько разных devel-пакетов для разных библиотек. Как правило, это Понадобится perl, cpanm и local::lib, а также несколько разных devel-пакетов для разных библиотек. Как правило, это
@@ -63,5 +69,6 @@ https://home.openweathermap.org/api_keys . Free plan предлагает всё
В каталоге contrib находится скрипт для alpine linux, системы инициализации openrc. Этот скрипт достаточно положить В В каталоге contrib находится скрипт для alpine linux, системы инициализации openrc. Этот скрипт достаточно положить В
/etc/init.d/aleesa-webapp сконфигурить сервис по инструкции выше и после этого сервис запускается командой: /etc/init.d/aleesa-webapp сконфигурить сервис по инструкции выше и после этого сервис запускается командой:
service aleesa-webapp start service aleesa-webapp start
в автозагрузку его можно прописать через команду
в автозагрузку его можно прописать через команду:
rc-update add aleesa-webapp default rc-update add aleesa-webapp default

8
TODO
View File

@@ -1,8 +0,0 @@
Приоритетные задачи:
Нет
Неприоритетные задачи:
* В парсере обрабатывать параметр plugin.
Формально, клиенты не должны знать, как работает этот чёрный ящик. Послал
сообщение - получил ответ, а уж как он там получается - это неважно. Тем не
менее возможность напрямую дёрнуть один из плагинов должна быть.

35
bin/aleesa-webapp
View File

@@ -1,6 +1,6 @@
#!/usr/bin/perl #!/usr/bin/perl
use 5.018; use 5.018; ## no critic (ProhibitImplicitImport)
use strict; use strict;
use warnings; use warnings;
use utf8; use utf8;
@@ -29,9 +29,10 @@ no Cwd;
use Cwd::utf8 qw (chdir abs_path); use Cwd::utf8 qw (chdir abs_path);
use File::Basename qw (basename dirname); use File::Basename qw (basename dirname);
use File::Path qw (make_path); use File::Path qw (make_path);
use File::Spec ();
use Log::Any qw ($log); use Log::Any qw ($log);
use Log::Any::Adapter; use Log::Any::Adapter ();
use Log::Any::For::Std; use Log::Any::For::Std ();
use POSIX qw (setgid setuid setsid); use POSIX qw (setgid setuid setsid);
use Conf qw (LoadConf); use Conf qw (LoadConf);
@@ -69,8 +70,8 @@ if ($UID == 0) {
make_path ( make_path (
$piddir, { $piddir, {
uid => $uid, uid => $uid,
group => $gid group => $gid,
} },
); );
} }
@@ -81,8 +82,8 @@ if ($UID == 0) {
make_path ( make_path (
$logdir, { $logdir, {
uid => $uid, uid => $uid,
group => $gid group => $gid,
} },
) or die "Unable to create $logdir: $OS_ERROR\n"; ) or die "Unable to create $logdir: $OS_ERROR\n";
} }
} }
@@ -102,14 +103,14 @@ if (defined $logfile) {
# verbosity paticulary for CHI. # verbosity paticulary for CHI.
Log::Any::Adapter->set ( Log::Any::Adapter->set (
{ {
category => 'CHI::Driver' category => 'CHI::Driver',
}, },
'File', 'File',
$logfile, $logfile,
log_level => 'warn' log_level => 'warn',
); );
} else { } else {
Log::Any::Adapter->set ('File', '/dev/null'); Log::Any::Adapter->set ('File', File::Spec->devnull);
} }
# по-умолчанию, демонизируемся, если явно не указано, что этого делать не надо # по-умолчанию, демонизируемся, если явно не указано, что этого делать не надо
@@ -125,7 +126,7 @@ my $apath = abs_path $PROGRAM_NAME;
unless (defined $apath) { unless (defined $apath) {
$log->fatal ("[FATAL] Unable to get abs_path: $OS_ERROR\n"); $log->fatal ("[FATAL] Unable to get abs_path: $OS_ERROR\n");
exit 1; exit 1;
}; }
my $pidfile = sprintf '%s/%s.pid', $piddir, basename $apath; my $pidfile = sprintf '%s/%s.pid', $piddir, basename $apath;
$log->info ("[INFO] Creating pidfile at $pidfile"); $log->info ("[INFO] Creating pidfile at $pidfile");
@@ -151,7 +152,7 @@ $PROGRAM_NAME = abs_path $PROGRAM_NAME; ## no critic (Variables::Re
# run bot, at last # run bot, at last
RunWebApp (); RunWebApp ();
if (-f $pidfile) { if (-e $pidfile) {
unlink $pidfile; unlink $pidfile;
} }
@@ -159,11 +160,11 @@ exit 0;
sub daemonize { sub daemonize {
__fork (); __fork ();
POSIX::setsid (); setsid ();
open STDIN, '<', '/dev/null'; ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen) open STDIN, '<', File::Spec->devnull; ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
# we handle STDOUT && STDERR via Log::Any::For::Std, so do not close them explicitly # we handle STDOUT && STDERR via Log::Any::For::Std, so do not close them explicitly
#open STDOUT, '>', '/dev/null'; ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen) #open STDOUT, '>', File::Spec->devnull; ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
#open STDERR, '>', '/dev/null'; ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen) #open STDERR, '>', File::Spec->devnull; ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
__fork (); __fork ();
umask 0; umask 0;
return; return;
@@ -187,7 +188,7 @@ sub __fork {
sub __signal_handler { sub __signal_handler {
$log->info ("[INFO] Caught a signal $OS_ERROR"); $log->info ("[INFO] Caught a signal $OS_ERROR");
if (-f $pidfile) { if (-e $pidfile) {
unlink $pidfile; unlink $pidfile;
} }

2
bin/flickr_init.pl
View File

@@ -1,6 +1,6 @@
#!/usr/bin/perl #!/usr/bin/perl
use 5.018; use 5.018; ## no critic (ProhibitImplicitImport)
use strict; use strict;
use warnings; use warnings;
use utf8; use utf8;

10
cpanfile
View File

@@ -1,6 +1,8 @@
## no critic
requires 'Carp', '==1.50'; requires 'Carp', '==1.50';
requires 'CHI', '==0.61'; requires 'CHI', '==0.61';
requires 'CHI::Driver::BerkeleyDB', '==0.05'; requires 'CHI::Driver::BerkeleyDB', '==0.05';
requires 'Clone', '==0.45';
requires 'Cwd', '==3.75'; requires 'Cwd', '==3.75';
requires 'Cwd::utf8', '==0.011'; requires 'Cwd::utf8', '==0.011';
requires 'DateTime', '==1.55'; requires 'DateTime', '==1.55';
@@ -8,8 +10,9 @@ requires 'Digest::HMAC_SHA1', '==1.04';
requires 'Encode', '==3.16'; requires 'Encode', '==3.16';
requires 'English', '0'; requires 'English', '0';
requires 'EV', '==4.33'; requires 'EV', '==4.33';
requires 'File::Basename', '0'; requires 'File::Basename', '==2.85';
requires 'File::Path', '==2.18'; requires 'File::Path', '==2.18';
requires 'File::Spec', '==3.75';
requires 'HTML::TokeParser', '==3.76'; requires 'HTML::TokeParser', '==3.76';
requires 'IO::Socket::SSL', '==2.073'; requires 'IO::Socket::SSL', '==2.073';
requires 'JSON', '==4.04'; requires 'JSON', '==4.04';
@@ -20,12 +23,13 @@ requires 'Log::Any::Adapter', '==1.710';
requires 'Log::Any::For::Std', '==0.05'; requires 'Log::Any::For::Std', '==0.05';
requires 'Math::Random::Secure', '==0.080001'; requires 'Math::Random::Secure', '==0.080001';
requires 'MIME::Base64', '==3.16'; requires 'MIME::Base64', '==3.16';
requires 'Mojolicious', '==9.22'; requires 'Mojolicious', '==9.26';
requires 'Mojo::IOLoop::Signal', '==0.003'; requires 'Mojo::IOLoop::Signal', '==0.003';
# Чтобы заткнуть Mojo::UserAgent::Cached
requires 'Mojo::Log', '0';
requires 'Mojo::Redis', '==3.27'; requires 'Mojo::Redis', '==3.27';
requires 'Mojo::UserAgent', '0'; requires 'Mojo::UserAgent', '0';
requires 'Mojo::UserAgent::Cached', '==1.18'; requires 'Mojo::UserAgent::Cached', '==1.18';
requires 'POSIX', '0'; requires 'POSIX', '0';
requires 'Protocol::Redis::XS', '0';
requires 'URI::Encode::XS', '==0.11'; requires 'URI::Encode::XS', '==0.11';
requires 'URI::URL', '==5.10'; requires 'URI::URL', '==5.10';

31
data/useragents.txt Normal file
View File

@@ -0,0 +1,31 @@
Mozilla/5.0 (Macintosh; Intel Mac OS X 12_2) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/98.0.4758.81 Safari/537.36 OPR/83.0.4254.27
Mozilla/5.0 (Windows NT 10.0) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/98.0.4758.81 Safari/537.36
Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/87.0.4280.88 Safari/537.36 Vivaldi/3.5
Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/88.0.4324.182 Safari/537.36 Edg/88.0.705.81
Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/89.0.4389.114 Safari/537.36
Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/92.0.4515.159 Safari/537.36
Mozilla/5.0 (Macintosh; Intel Mac OS X 10_15_7) AppleWebKit/605.1.15 (KHTML, like Gecko) Version/15.2 Safari/605.1.15
Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/95.0.4638.69 Safari/537.36
Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/95.0.4638.69 Safari/537.36 Edg/95.0.1020.44
Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/96.0.4664.110 Safari/537.36
Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/96.0.4664.110 Safari/537.36 Edg/96.0.1054.62
Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/96.0.4664.110 Safari/537.36 OPR/82.0.4227.50
Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/97.0.4692.71 Safari/537.36 Edg/97.0.1072.55
Mozilla/5.0 (Macintosh; Intel Mac OS X 12_2) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/98.0.4758.81 Safari/537.36
Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/98.0.4758.81 Safari/537.36
Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/98.0.4758.81 Safari/537.36 Edg/97.0.1072.69
Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/98.0.4758.81 Safari/537.36 Vivaldi/4.3
Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/98.0.4758.81 YaBrowser/22.1.0 Yowser/2.5 Safari/537.36
Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:91.0) Gecko/20100101 Firefox/91.0
Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:95.0) Gecko/20100101 Firefox/95.0
Mozilla/5.0 (Macintosh; Intel Mac OS X 10_15_6) AppleWebKit/605.1.15 (KHTML, like Gecko) Version/15.1 Safari/605.1.15
Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:96.0) Gecko/20100101 Firefox/96.0
Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:97.0) Gecko/20100101 Firefox/97.0
Mozilla/5.0 (Windows NT 10.0; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/87.0.4280.88 Safari/537.36 Vivaldi/3.5
Mozilla/5.0 (Windows NT 10.0; WOW64; Trident/7.0; rv:11.0) like Gecko
Mozilla/5.0 (Windows NT 10.0; WOW64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/98.0.4758.81 Safari/537.36 OPR/83.0.4254.27
Mozilla/5.0 (X11; Fedora; Linux x86_64; rv:91.0) Gecko/20100101 Firefox/91.0
Mozilla/5.0 (X11; Linux x86_64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/98.0.4758.81 Safari/537.36 OPR/83.0.4254.27
Mozilla/5.0 (X11; Linux x86_64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/98.0.4758.81 Safari/537.36 Vivaldi/4.3
Mozilla/5.0 (X11; Ubuntu; Linux i686; rv:91.0) Gecko/20100101 Firefox/91.0
Mozilla/5.0 (X11; Ubuntu; Linux x86_64; rv:97.0) Gecko/20100101 Firefox/97.0

22
lib/Conf.pm
View File

@@ -1,14 +1,13 @@
package Conf; package Conf;
# Загружает конфиг # Загружает конфиг файл
use 5.018; use 5.018; ## no critic (ProhibitImplicitImport)
use strict; use strict;
use warnings; 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);
use Exporter qw (import); use Exporter qw (import);
@@ -16,17 +15,26 @@ 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"; my $CH;
my $json;
unless (open $CH, '<', $c) {
die "[FATAL] No conf at $c: $OS_ERROR\n";
}
my $len = (stat $c) [7]; my $len = (stat $c) [7];
my $json;
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);

212
lib/WebApp.pm
View File

@@ -1,19 +1,20 @@
package WebApp; package WebApp;
# Общие модули - синтаксис, кодировки итд # Общие модули - синтаксис, кодировки итд
use 5.018; use 5.018; ## no critic (ProhibitImplicitImport)
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 Clone qw (clone);
use Data::Dumper qw (Dumper);
use Log::Any qw ($log); use Log::Any qw ($log);
use Math::Random::Secure qw (irand); use Math::Random::Secure qw (irand);
use Mojo::Redis; use Mojo::Redis ();
use Mojo::IOLoop; use Mojo::IOLoop ();
use Mojo::IOLoop::Signal; use Mojo::IOLoop::Signal ();
# Плагины web-клиентов # Плагины web-клиентов
use Conf qw (LoadConf); use Conf qw (LoadConf);
@@ -24,23 +25,51 @@ 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 $fwd_cnt = 5;
if (defined $c->{'forward_max'}) {
$fwd_cnt = $c->{'forward_max'};
}
# Основной парсер # Основной парсер
my $parse_message = sub { my $parse_message = sub {
my $self = shift; my $self = shift;
my $m = shift; my $m = shift;
my $answer = $m;
$log->debug ('[DEBUG] Incoming message ' . Dumper ($m));
unless (defined $m->{message}) {
$log->error (sprintf 'Unable to process unknown message: %s', $m->{message});
return;
}
my $answer = clone ($m);
$answer->{from} = 'webapp'; $answer->{from} = 'webapp';
$answer->{message} = undef;
my $send_to = $m->{plugin}; my $send_to = $m->{plugin};
my $reply; my $reply;
# Если $answer->{misc}->{answer} не существует, то проставим его как 1, предполагаем, что по-умолчанию ответ от нас
# всё-таки ожидают. Если что - уточним ниже.
if (defined $answer->{misc}) { if (defined $answer->{misc}) {
unless (defined $answer->{misc}->{answer}) {
$answer->{misc}->{answer} = 1;
}
unless (defined $answer->{misc}->{bot_nick}) {
$answer->{misc}->{bot_nick} = undef;
}
unless (defined $answer->{misc}->{csign}) {
$answer->{misc}->{csign} = '!';
}
unless (defined $answer->{misc}->{fwd_cnt}) { unless (defined $answer->{misc}->{fwd_cnt}) {
$answer->{misc}->{fwd_cnt} = 1; $answer->{misc}->{fwd_cnt} = 1;
} else { } else {
if ($answer->{misc}->{fwd_cnt} > $fwd_cnt) { if ($answer->{misc}->{fwd_cnt} > $fwd_cnt) {
$log->error ('Forward loop detected, discarding message.'); $log->error ('[ERROR] Forward loop detected, discarding message.');
$log->debug (Dumper $m); $log->debug (Dumper $m);
return; return;
} else { } else {
@@ -48,111 +77,120 @@ my $parse_message = sub {
} }
} }
unless (defined $answer->{misc}->{answer}) { unless (defined $answer->{misc}->{good_morning}) {
$answer->{misc}->{answer} = 1; $answer->{misc}->{good_morning} = 0;
} }
unless (defined $answer->{misc}->{csign}) { unless (defined $answer->{misc}->{msg_format}) {
$answer->{misc}->{csign} = '!';
}
} else {
$answer->{misc}->{answer} = 1;
$answer->{misc}->{csign} = '!';
$answer->{misc}->{msg_format} = 0; $answer->{misc}->{msg_format} = 0;
} }
$log->debug ('[DEBUG] Incoming message ' . Dumper($m)); unless (defined $answer->{misc}->{username}) {
$answer->{misc}->{username} = 'user';
}
} else {
$answer->{misc}->{answer} = 1;
$answer->{misc}->{bot_nick} = undef;
$answer->{misc}->{csign} = $c->{csign};
$answer->{misc}->{fwd_cnt} = 1;
$answer->{misc}->{good_morning} = 0;
$answer->{misc}->{msg_format} = 0;
$answer->{misc}->{username} = 'user';
}
if (substr ($m->{message}, 1) eq 'buni') { if (length $m->{message} <= length $answer->{misc}->{csign}) {
$log->info (sprintf 'Unable to process unknown message: %s', $m->{message});
return;
}
if (substr ($m->{message}, 0, length ($answer->{misc}->{csign})) ne $answer->{misc}->{csign}) {
$log->info (sprintf 'Unable to process unknown message: %s', $m->{message});
return;
}
my $cmd = substr $m->{message}, length ($answer->{misc}->{csign});
if ($cmd eq 'buni') {
if (($m->{plugin} eq 'telegram') && $answer->{misc}->{msg_format}) {
$reply = sprintf '[buni](%s)', Buni ();
} else {
$reply = 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') { } elsif ($cmd eq 'anek' || $cmd eq 'анек' || $cmd eq 'анекдот') {
if (($m->{plugin} eq 'telegram') && $answer->{misc}->{msg_format}) {
$reply = "```\n" . Anek () . "\n```"; $reply = "```\n" . Anek () . "\n```";
$answer->{misc}->{msg_format} = 1;
} else { } else {
$reply = Anek (); $reply = Anek ();
} }
} elsif (substr ($m->{message}, 1) eq 'cat' || substr ($m->{message}, 1) eq 'кис') { } elsif ($cmd eq 'cat' || $cmd eq 'кис') {
if ($m->{plugin} eq 'telegram') { if (($m->{plugin} eq 'telegram') && $answer->{misc}->{msg_format}) {
my @cats = ('龴ↀ◡ↀ龴', '=^..^=', '≧◔◡◔≦ ','^ↀᴥↀ^'); my @cats = ('龴ↀ◡ↀ龴', '=^..^=', '≧◔◡◔≦ ','^ↀᴥↀ^');
my $cat = Kitty (); $reply = sprintf '[%s](%s)', $cats[irand ($#cats + 1)], Kitty ();
$reply = sprintf '[%s](%s)', $cats[irand ($#cats + 1)], $cat;
$answer->{misc}->{msg_format} = 1;
} else { } else {
$reply = Kitty (); $reply = Kitty ();
} }
} elsif (substr ($m->{message}, 1) eq 'drink' || substr ($m->{message}, 1) eq 'праздник') { } elsif ($cmd eq 'drink' || $cmd eq 'праздник') {
$reply = Drink (); $reply = Drink ();
} elsif (substr ($m->{message}, 1) eq 'fox' || substr ($m->{message}, 1) eq 'лис') { } elsif ($cmd eq 'fox' || $cmd eq 'лис') {
if ($m->{plugin} eq 'telegram') { if (($m->{plugin} eq 'telegram') && $answer->{misc}->{msg_format}) {
my $fox = Fox (); $reply = sprintf '[-^^,--,~](%s)', Fox ();
$reply = sprintf '[-^^,--,~](%s)', $fox;
$answer->{misc}->{msg_format} = 1;
} else { } else {
$reply = Fox (); $reply = Fox ();
} }
} elsif (substr ($m->{message}, 1) eq 'frog' || substr ($m->{message}, 1) eq 'лягушка') { } elsif ($cmd eq 'frog' || $cmd eq 'лягушка') {
if ($m->{plugin} eq 'telegram') { if (($m->{plugin} eq 'telegram') && $answer->{misc}->{msg_format}) {
my @art = qw (frog toad лягушка); my @art = qw (frog toad лягушка);
my $frog = Frog (); $reply = sprintf '[%s](%s)', $art [irand ($#art + 1)], Frog ();
$reply = sprintf '[%s](%s)', $art [irand ($#art + 1)], $frog;
$answer->{misc}->{msg_format} = 1;
} else { } else {
$reply = Frog (); $reply = Frog ();
} }
} elsif (substr ($m->{message}, 1) eq 'horse' || substr ($m->{message}, 1) eq 'лошадь' || substr ($m->{message}, 1) eq 'лошадка') { } elsif ($cmd eq 'horse' || $cmd eq 'лошадь' || $cmd eq 'лошадка') {
if ($m->{plugin} eq 'telegram') { if (($m->{plugin} eq 'telegram') && $answer->{misc}->{msg_format}) {
my @art = qw (horse лошадь лошадка); my @art = qw (horse лошадь лошадка);
my $horse = Horse (); $reply = sprintf '[%s](%s)', $art [irand ($#art + 1)], Horse ();
$reply = sprintf '[%s](%s)', $art [irand ($#art + 1)], $horse;
$answer->{misc}->{msg_format} = 1;
} else { } else {
$reply = Horse (); $reply = Horse ();
} }
} elsif (substr ($m->{message}, 1) eq 'monkeyuser') { } elsif ($cmd eq 'monkeyuser') {
if (($m->{plugin} eq 'telegram') && $answer->{misc}->{msg_format}) {
$reply = sprintf '[monkeyuser](%s)', Monkeyuser ();
} else {
$reply = Monkeyuser (); $reply = Monkeyuser ();
} elsif (substr ($m->{message}, 1) eq 'owl' || substr ($m->{message}, 1) eq 'сова' || substr ($m->{message}, 1) eq 'сыч') { }
if ($m->{plugin} eq 'telegram') { } elsif ($cmd eq 'owl' || $cmd eq 'сова' || $cmd eq 'сыч') {
my $owl = Owl (); if (($m->{plugin} eq 'telegram') && $answer->{misc}->{msg_format}) {
$reply = sprintf '[{ O v O }](%s)', $owl; $reply = sprintf '[{ O v O }](%s)', Owl ();
$answer->{misc}->{msg_format} = 1;
} else { } else {
$reply = Owl (); $reply = Owl ();
} }
} elsif (substr ($m->{message}, 1) eq 'rabbit' || substr ($m->{message}, 1) eq 'bunny' || substr ($m->{message}, 1) eq 'кролик') { } elsif ($cmd eq 'rabbit' || $cmd eq 'bunny' || $cmd eq 'кролик') {
if ($m->{plugin} eq 'telegram') { if (($m->{plugin} eq 'telegram') && $answer->{misc}->{msg_format}) {
my $rabbit = Rabbit (); $reply = sprintf '[(\_/)](%s)', Rabbit ();
$reply = sprintf '[(\_/)](%s)', $rabbit;
$answer->{misc}->{msg_format} = 1;
} else { } else {
$reply = Rabbit (); $reply = Rabbit ();
} }
} elsif (substr ($m->{message}, 1) eq 'snail' || substr ($m->{message}, 1) eq 'улитка') { } elsif ($cmd eq 'snail' || $cmd eq 'улитка') {
if ($m->{plugin} eq 'telegram') { if (($m->{plugin} eq 'telegram') && $answer->{misc}->{msg_format}) {
my @art = qw ('-'_@_ @╜ @_'-'); my @art = qw ('-'_@_ @╜ @_'-');
my $snail = Snail (); $reply = sprintf '[%s](%s)', $art [irand ($#art + 1)], Snail ();
$reply = sprintf '[%s](%s)', $art [irand ($#art + 1)], $snail;
$answer->{misc}->{msg_format} = 1;
} else { } else {
$reply = Snail (); $reply = Snail ();
} }
} elsif (substr ($m->{message}, 1) eq 'xkcd') { } elsif ($cmd eq 'xkcd') {
if (($m->{plugin} eq 'telegram') && $answer->{misc}->{msg_format}) {
$reply = sprintf '[xkcd](%s)', Xkcd ();
} else {
$reply = Xkcd (); $reply = Xkcd ();
} elsif (substr ($m->{message}, 1, 2) eq 'w ' || substr ($m->{message}, 1, 2) eq 'п ') { }
my $city = substr $m->{message}, 2; } elsif ($cmd =~ /^(w|weather|п|погода|погодка|погадка)\s+(.+)$/gui) {
my $city = $2;
$reply = 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 'погадка ') { } elsif ($cmd eq 'tits' ||
my $city = substr $m->{message}, 9; $cmd eq 'boobs' ||
$reply = Weather ($city); $cmd eq 'tities' ||
} elsif (substr ($m->{message}, 1, 7) eq 'погода ') { $cmd eq 'boobies' ||
my $city = substr $m->{message}, 8; $cmd eq 'сиси' ||
$reply = Weather ($city); $cmd eq 'сисечки') {
} 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') { if ($m->{plugin} eq 'telegram') {
my @art = ('(. )( .)', '( . Y . )', '(o)(o)', '( @ )( @ )', '(.)(.)'); my @art = ('(. )( .)', '( . Y . )', '(o)(o)', '( @ )( @ )', '(.)(.)');
my $oboobs = Oboobs (); my $oboobs = Oboobs ();
@@ -161,11 +199,11 @@ my $parse_message = sub {
} else { } else {
$reply = Oboobs (); $reply = Oboobs ();
} }
} elsif (substr ($m->{message}, 1) eq 'butt' || } elsif ($cmd eq 'butt' ||
substr ($m->{message}, 1) eq 'booty' || $cmd eq 'booty' ||
substr ($m->{message}, 1) eq 'ass' || $cmd eq 'ass' ||
substr ($m->{message}, 1) eq 'попа' || $cmd eq 'попа' ||
substr ($m->{message}, 1) eq 'попка') { $cmd eq 'попка') {
if ($m->{plugin} eq 'telegram') { if ($m->{plugin} eq 'telegram') {
my @art = ('(__(__)', '(_!_)', '(__.__)'); my @art = ('(__(__)', '(_!_)', '(__.__)');
my $obutts = Obutts (); my $obutts = Obutts ();
@@ -183,7 +221,7 @@ my $parse_message = sub {
$log->debug ("[DEBUG] Sending message to channel $send_to " . Dumper ($answer)); $log->debug ("[DEBUG] Sending message to channel $send_to " . Dumper ($answer));
$self->json ($send_to)->notify ( $self->json ($send_to)->notify (
$send_to => $answer $send_to => $answer,
); );
} }
@@ -194,7 +232,7 @@ my $__signal_handler = sub {
my ($self, $name) = @_; my ($self, $name) = @_;
$log->info ("[INFO] Caught a signal $name"); $log->info ("[INFO] Caught a signal $name");
if (defined $main::pidfile && -f $main::pidfile) { if (defined $main::pidfile && -e $main::pidfile) {
unlink $main::pidfile; unlink $main::pidfile;
} }
@@ -207,7 +245,7 @@ sub RunWebApp {
$log->info ("[INFO] Connecting to $c->{server}, $c->{port}"); $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'); $log->info ('[INFO] Registering connection-event callback');
@@ -224,11 +262,11 @@ sub RunWebApp {
my ($conn, $error) = @_; my ($conn, $error) = @_;
$log->error ("[ERROR] Redis connection error: $error"); $log->error ("[ERROR] Redis connection error: $error");
return; return;
} },
); );
return; return;
} },
); );
my $pubsub = $redis->pubsub; my $pubsub = $redis->pubsub;
@@ -239,14 +277,12 @@ sub RunWebApp {
$log->debug ("[DEBUG] Subscribing to $channel"); $log->debug ("[DEBUG] Subscribing to $channel");
$sub->{$channel} = $pubsub->json ($channel)->listen ( $sub->{$channel} = $pubsub->json ($channel)->listen (
$channel => sub { $parse_message->(@_); } $channel => sub { $parse_message->(@_); },
); );
} }
Mojo::IOLoop::Signal->on ( Mojo::IOLoop::Signal->on (TERM => $__signal_handler);
TERM => $__signal_handler, Mojo::IOLoop::Signal->on (INT => $__signal_handler);
INT => $__signal_handler
);
do { Mojo::IOLoop->start } until Mojo::IOLoop->is_running; do { Mojo::IOLoop->start } until Mojo::IOLoop->is_running;
return; return;

126
lib/WebApp/Client.pm
View File

@@ -1,6 +1,6 @@
package WebApp::Client; package WebApp::Client;
use 5.018; use 5.018; ## no critic (ProhibitImplicitImport)
use strict; use strict;
use warnings; use warnings;
use utf8; use utf8;
@@ -8,19 +8,21 @@ use open qw (:std :utf8);
use English qw ( -no_match_vars ); use English qw ( -no_match_vars );
use Carp qw (carp cluck); use Carp qw (carp cluck);
use CHI; use CHI ();
use CHI::Driver::BerkeleyDB; use CHI::Driver::BerkeleyDB ();
use DateTime; use DateTime ();
use Encode; use Encode qw (decode);
use HTML::TokeParser; use File::Spec ();
use JSON::XS; use HTML::TokeParser ();
use JSON::XS ();
use Log::Any qw ($log); use Log::Any qw ($log);
use Math::Random::Secure qw (irand); use Math::Random::Secure qw (irand);
use Mojo::UserAgent; use Mojo::Log (); # Чтобы заткнуть Mojo::UserAgent::Cached
use Mojo::UserAgent::Cached; use Mojo::UserAgent ();
use Mojo::UserAgent::Cached ();
use Mojo::Util qw (trim); use Mojo::Util qw (trim);
use POSIX qw (strftime); use POSIX qw (strftime);
use URI::URL; use URI::URL qw (url);
use Conf qw (LoadConf); use Conf qw (LoadConf);
use WebApp::Client::API::Flickr qw (FlickrByTags); use WebApp::Client::API::Flickr qw (FlickrByTags);
@@ -33,6 +35,41 @@ my @MONTH = qw (yanvar fevral mart aprel may iyun iyul avgust sentyabr oktyabr n
my $c = LoadConf (); my $c = LoadConf ();
my $cachedir = $c->{cachedir}; my $cachedir = $c->{cachedir};
my @useragents = _get_ua_list ();
sub _get_ua_list {
my $file = $c->{useragentfile};
my $file_opened = 1;
open my $FILEHANDLE, '<', $file || do {
carp "[ERROR] No browser useragent list at $file: $OS_ERROR\n";
$file_opened = 0;
};
my @ua_list;
if ($file_opened) {
while (my $str = <$FILEHANDLE>) {
chomp $str;
next unless $str eq '';
push @ua_list, $str;
}
close $FILEHANDLE; ## no critic (InputOutput::RequireCheckedSyscalls
return @ua_list;
}
if ($#ua_list < 31) {
carp "[ERROR] Useragent list in $file have less than 31 enties, discarding it\n";
$#ua_list = -1;
} elsif ($#ua_list > 31) {
carp "[INFO] Useragent list in $file have more than 31 enties, truncating it to 31 entries\n";
$#ua_list = 31;
}
return @ua_list;
}
sub urlencode { sub urlencode {
my $str = shift; my $str = shift;
@@ -139,7 +176,7 @@ sub Buni {
@a = $p->get_tag ('meta'); ## no critic (Variables::RequireLocalizedPunctuationVars) @a = $p->get_tag ('meta'); ## no critic (Variables::RequireLocalizedPunctuationVars)
if (defined $a[0][1]->{property} && $a[0][1]->{property} eq 'og:image') { if (defined $a[0][1]->{property} && $a[0][1]->{property} eq 'og:image') {
$ret = sprintf '[buni](%s)', $a[0][1]->{content}; $ret = $a[0][1]->{content};
last; last;
} }
@@ -156,7 +193,7 @@ sub Drink {
my $r; my $r;
my $ret = 'Не знаю праздников - вджобываю весь день на шахтах, как проклятая.'; my $ret = 'Не знаю праздников - вджобываю весь день на шахтах, как проклятая.';
my ($dayNum, $monthNum) = (localtime ())[3, 4]; my ($dayNum, $monthNum) = (localtime ())[3, 4];
my $url = sprintf 'https://kakoysegodnyaprazdnik.ru/baza/%s/%s', $MONTH[$monthNum], $dayNum; my $url = 'https://prazdniki-segodnya.ru/';
# Those POSIX assholes just forgot to add unix timestamps without TZ offset, so... # Those POSIX assholes just forgot to add unix timestamps without TZ offset, so...
my ($mday, $mon, $year) = (gmtime ())[3, 4, 5]; my ($mday, $mon, $year) = (gmtime ())[3, 4, 5];
@@ -175,7 +212,7 @@ sub Drink {
day => $mday, day => $mday,
hour => 0, hour => 0,
minute => 0, minute => 0,
second => 0 second => 0,
)->add (days => 1)->strftime ('%s'); )->add (days => 1)->strftime ('%s');
if ((substr $offset, 0, 1) eq '+') { if ((substr $offset, 0, 1) eq '+') {
@@ -193,10 +230,18 @@ sub Drink {
namespace => __PACKAGE__, namespace => __PACKAGE__,
expires_at => $expirationDate, expires_at => $expirationDate,
expires_on_backend => 1, expires_on_backend => 1,
) ),
); );
# just to make Mojo::UserAgent::Cached happy # just to make Mojo::UserAgent::Cached happy
$ua->logger (Mojo::Log->new (path => '/dev/null', level => 'error')); $ua->logger (Mojo::Log->new (path => File::Spec->devnull, level => 'error'));
my $useragent = 'Mozilla/5.0 (Macintosh; Intel Mac OS X 10_15_7) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/98.0.4758.80 Safari/537.36';
if ($#useragents > 0) {
$useragent = $useragents [ (localtime ()) [3] ];
}
$ua->transactor->name ($useragent);
$r = $ua->get ($url => {'Accept-Language' => 'ru-RU', 'Accept-Charset' => 'utf-8'})->result; $r = $ua->get ($url => {'Accept-Language' => 'ru-RU', 'Accept-Charset' => 'utf-8'})->result;
if ($r->is_success) { if ($r->is_success) {
@@ -209,28 +254,33 @@ sub Drink {
if ($r->is_success) { if ($r->is_success) {
my $p = HTML::TokeParser->new(\$r->body); my $p = HTML::TokeParser->new(\$r->body);
my @a; my @a;
my @holyday; my %holiday;
do { do {
$#a = -1; $#a = -1;
@a = $p->get_tag('span'); ## no critic (Variables::RequireLocalizedPunctuationVars) @a = $p->get_tag ('div'); ## no critic (Variables::RequireLocalizedPunctuationVars)
if ($#{$a[0]} > 2 && defined $a[0][1]->{itemprop} && $a[0][1]->{itemprop} eq 'text') { if ($#{$a[0]} > 2) {
push @holyday,'* ' . decode ('UTF-8', $p->get_trimmed_text ('/span')); my @shitty_array = $a[0];
foreach my $item (@shitty_array) {
if (ref $item) {
foreach my $item1 (@{$item}) {
my %h = eval { %{$item1} };
if (defined ($h{class}) && $h{class} eq 'list-group-item text-monospace') {
$holiday {'* ' . decode ('UTF-8', $p->get_trimmed_text ('/div'))} = 1;
}
}
}
}
} }
} while ($#{$a[0]} > 1); } while ($#{$a[0]} > 1);
if ($#holyday > 0) { if (int (keys (%holiday)) > 0) {
# cut off something weird, definely not a "holyday" $ret = join "\n", sort (keys (%holiday));
$#holyday = $#holyday - 1;
}
if ($#holyday > 0) {
$ret = join "\n", @holyday;
} }
} else { } else {
$log->warn (sprintf '[WARN] Kakoysegodnyaprazdnik server return status %s with message: %s', $r->code, $r->message); $log->warn (sprintf '[WARN] prazdniki-segodnya.ru server return status %s with message: %s', $r->code, $r->message);
} }
return $ret; return $ret;
@@ -269,7 +319,7 @@ sub Monkeyuser {
} while ($#{$a[0]} > 1); } while ($#{$a[0]} > 1);
if ($#link > 0) { if ($#link > 0) {
$ret = sprintf '[MonkeyUser](https://www.monkeyuser.com%s)', $link [irand (1 + $#link)]; $ret = sprintf 'https://www.monkeyuser.com%s', $link [irand (1 + $#link)];
} }
} else { } else {
$log->warn (sprintf '[WARN] MonkeyUser server return status %s with message: %s', $r->{status}, $r->{reason}); $log->warn (sprintf '[WARN] MonkeyUser server return status %s with message: %s', $r->{status}, $r->{reason});
@@ -470,7 +520,7 @@ sub Xkcd {
my $ua = Mojo::UserAgent->new->connect_timeout (5)->max_redirects (0); my $ua = Mojo::UserAgent->new->connect_timeout (5)->max_redirects (0);
my $location; my $location;
my $status = 400; my $status = 400;
my $c = 0; my $counter = 0;
do { do {
my $r = $ua->get ('https://xkcd.ru/random/')->result; my $r = $ua->get ('https://xkcd.ru/random/')->result;
@@ -486,12 +536,12 @@ sub Xkcd {
$r = $ua->head ($location)->result; $r = $ua->head ($location)->result;
} }
$c++; $counter++;
$status = $r->code; $status = $r->code;
} while ($c < 3 || $status >= 404); } while ($c < 3 || $status >= 404);
if ($status == 200) { if ($status == 200) {
return sprintf '[xkcd.ru](%s)', $location; return $location;
} }
return 'Комикс-стрип нарисовать не так-то просто :('; return 'Комикс-стрип нарисовать не так-то просто :(';
@@ -529,7 +579,7 @@ sub Weather {
$w->{temperature_min}, $w->{temperature_min},
$w->{temperature_feelslike}, $w->{temperature_feelslike},
$w->{humidity}, $w->{humidity},
$w->{pressure} $w->{pressure},
); );
} elsif ($w->{temperature_min} < 0 && $w->{temperature_max} <= 0) { } elsif ($w->{temperature_min} < 0 && $w->{temperature_max} <= 0) {
$reply = sprintf ( $reply = sprintf (
@@ -543,7 +593,7 @@ sub Weather {
$w->{temperature_min}, $w->{temperature_min},
$w->{temperature_feelslike}, $w->{temperature_feelslike},
$w->{humidity}, $w->{humidity},
$w->{pressure} $w->{pressure},
); );
} else { } else {
$reply = sprintf ( $reply = sprintf (
@@ -557,7 +607,7 @@ sub Weather {
$w->{temperature_max}, $w->{temperature_max},
$w->{temperature_feelslike}, $w->{temperature_feelslike},
$w->{humidity}, $w->{humidity},
$w->{pressure} $w->{pressure},
); );
} }
} else { } else {
@@ -588,10 +638,10 @@ sub __weather {
namespace => __PACKAGE__, namespace => __PACKAGE__,
expires_in => '3 hours', expires_in => '3 hours',
expires_on_backend => 1, expires_on_backend => 1,
) ),
); );
# just to make Mojo::UserAgent::Cached happy # just to make Mojo::UserAgent::Cached happy
$ua->logger (Mojo::Log->new (path => '/dev/null', level => 'error')); $ua->logger (Mojo::Log->new (path => File::Spec->devnull, level => 'error'));
$r = $ua->get (sprintf ('http://api.openweathermap.org/data/2.5/weather?q=%s&lang=ru&APPID=%s', $city, $appid))->result; $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) { if ($r->is_success) {
@@ -610,7 +660,7 @@ sub __weather {
unless ($fc) { unless ($fc) {
$log->warn ("[WARN] openweathermap returns corrupted json: $EVAL_ERROR"); $log->warn ("[WARN] openweathermap returns corrupted json: $EVAL_ERROR");
return undef; return undef;
}; }
} else { } else {
$log->warn (sprintf '[WARN] Server return status %s with message: %s', $r->code, $r->message); $log->warn (sprintf '[WARN] Server return status %s with message: %s', $r->code, $r->message);
return undef; return undef;

51
lib/WebApp/Client/API/Flickr.pm
View File

@@ -1,24 +1,23 @@
package WebApp::Client::API::Flickr; package WebApp::Client::API::Flickr;
use 5.018; use 5.018; ## no critic (ProhibitImplicitImport)
use strict; use strict;
use warnings; 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 Carp qw (cluck); use CHI ();
use CHI; use CHI::Driver::BerkeleyDB ();
use CHI::Driver::BerkeleyDB; use Digest::HMAC_SHA1 ();
use Digest::HMAC_SHA1 qw (hmac_sha1);
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 qw (encode_base64);
use Mojo::UserAgent; 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 Data::Dumper; use Data::Dumper qw (Dumper);
use version; our $VERSION = qw (1.0); use version; our $VERSION = qw (1.0);
use Exporter qw (import); use Exporter qw (import);
@@ -107,7 +106,7 @@ sub flickrRequestToken {
my $oauth_signature = flickerSignReq ( 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,
); );
my $url = $flickr_request_token_url . sprintf ( my $url = $flickr_request_token_url . sprintf (
@@ -116,7 +115,7 @@ sub flickrRequestToken {
$oauth_timestamp, $oauth_timestamp,
$flickr_consumer_key, $flickr_consumer_key,
uri_encode ($oauth_signature), uri_encode ($oauth_signature),
uri_encode ($flickr_callback_url) uri_encode ($flickr_callback_url),
); );
my $ua = Mojo::UserAgent->new->connect_timeout (5); my $ua = Mojo::UserAgent->new->connect_timeout (5);
@@ -147,7 +146,7 @@ sub flickrAccessToken {
oauth_nonce => $oauth_nonce, oauth_nonce => $oauth_nonce,
oauth_token => $flickr_request_token, oauth_token => $flickr_request_token,
oauth_token_secret => $flickr_request_token_secret, oauth_token_secret => $flickr_request_token_secret,
oauth_verifier => $flickr_verifier oauth_verifier => $flickr_verifier,
); );
my $url = $flickr_access_token_url . sprintf ( my $url = $flickr_access_token_url . sprintf (
@@ -157,7 +156,7 @@ sub flickrAccessToken {
$flickr_verifier, $flickr_verifier,
$flickr_consumer_key, $flickr_consumer_key,
$flickr_request_token, $flickr_request_token,
uri_encode ($oauth_signature) uri_encode ($oauth_signature),
); );
my $ua = Mojo::UserAgent->new->connect_timeout (5); my $ua = Mojo::UserAgent->new->connect_timeout (5);
@@ -211,7 +210,7 @@ sub flickrTestLogin {
oauth_token => $flickr_access_token, oauth_token => $flickr_access_token,
oauth_token_secret => $flickr_access_token_secret, oauth_token_secret => $flickr_access_token_secret,
oauth_signature_method => 'HMAC-SHA1', oauth_signature_method => 'HMAC-SHA1',
oauth_version => '1.0' oauth_version => '1.0',
); );
my $url = $flickr_api_url . sprintf ( my $url = $flickr_api_url . sprintf (
@@ -220,7 +219,7 @@ sub flickrTestLogin {
$flickr_consumer_key, $flickr_consumer_key,
$oauth_timestamp, $oauth_timestamp,
$flickr_access_token, $flickr_access_token,
uri_encode ($oauth_signature) uri_encode ($oauth_signature),
); );
my $ua = Mojo::UserAgent->new->connect_timeout (5); my $ua = Mojo::UserAgent->new->connect_timeout (5);
@@ -267,7 +266,7 @@ sub flickrSearchByText {
oauth_token => $flickr_access_token, oauth_token => $flickr_access_token,
oauth_token_secret => $flickr_access_token_secret, oauth_token_secret => $flickr_access_token_secret,
oauth_signature_method => 'HMAC-SHA1', oauth_signature_method => 'HMAC-SHA1',
oauth_version => '1.0' oauth_version => '1.0',
); );
my $url = $flickr_api_url . sprintf ( my $url = $flickr_api_url . sprintf (
@@ -277,7 +276,7 @@ sub flickrSearchByText {
$oauth_timestamp, $oauth_timestamp,
$flickr_access_token, $flickr_access_token,
uri_encode ($oauth_signature), uri_encode ($oauth_signature),
uri_encode ($text) uri_encode ($text),
); );
my $ua = Mojo::UserAgent->new->connect_timeout (5); my $ua = Mojo::UserAgent->new->connect_timeout (5);
@@ -309,7 +308,7 @@ sub flickrSearchByText {
oauth_token => $flickr_access_token, oauth_token => $flickr_access_token,
oauth_token_secret => $flickr_access_token_secret, oauth_token_secret => $flickr_access_token_secret,
oauth_signature_method => 'HMAC-SHA1', oauth_signature_method => 'HMAC-SHA1',
oauth_version => '1.0' oauth_version => '1.0',
); );
$url = $flickr_api_url . sprintf ( $url = $flickr_api_url . sprintf (
@@ -320,7 +319,7 @@ sub flickrSearchByText {
$flickr_access_token, $flickr_access_token,
uri_encode ($oauth_signature), uri_encode ($oauth_signature),
$page, $page,
uri_encode ($text) uri_encode ($text),
); );
$ua = Mojo::UserAgent->new->connect_timeout (5); $ua = Mojo::UserAgent->new->connect_timeout (5);
@@ -375,7 +374,7 @@ sub flickrSearchByTags {
oauth_token => $flickr_access_token, oauth_token => $flickr_access_token,
oauth_token_secret => $flickr_access_token_secret, oauth_token_secret => $flickr_access_token_secret,
oauth_signature_method => 'HMAC-SHA1', oauth_signature_method => 'HMAC-SHA1',
oauth_version => '1.0' oauth_version => '1.0',
); );
my $url = $flickr_api_url . sprintf ( my $url = $flickr_api_url . sprintf (
@@ -385,7 +384,7 @@ sub flickrSearchByTags {
$oauth_timestamp, $oauth_timestamp,
$flickr_access_token, $flickr_access_token,
uri_encode ($oauth_signature), uri_encode ($oauth_signature),
uri_encode ($tags) uri_encode ($tags),
); );
my $ua = Mojo::UserAgent->new->connect_timeout (5); my $ua = Mojo::UserAgent->new->connect_timeout (5);
@@ -417,7 +416,7 @@ sub flickrSearchByTags {
oauth_token => $flickr_access_token, oauth_token => $flickr_access_token,
oauth_token_secret => $flickr_access_token_secret, oauth_token_secret => $flickr_access_token_secret,
oauth_signature_method => 'HMAC-SHA1', oauth_signature_method => 'HMAC-SHA1',
oauth_version => '1.0' oauth_version => '1.0',
); );
$url = $flickr_api_url . sprintf ( $url = $flickr_api_url . sprintf (
@@ -428,7 +427,7 @@ sub flickrSearchByTags {
$flickr_access_token, $flickr_access_token,
uri_encode ($oauth_signature), uri_encode ($oauth_signature),
$page, $page,
uri_encode ($tags) uri_encode ($tags),
); );
$ua = Mojo::UserAgent->new->connect_timeout (5); $ua = Mojo::UserAgent->new->connect_timeout (5);
@@ -463,7 +462,7 @@ sub FlickrInit {
my $cache = CHI->new ( my $cache = CHI->new (
driver => 'BerkeleyDB', driver => 'BerkeleyDB',
root_dir => $cachedir, root_dir => $cachedir,
namespace => __PACKAGE__ namespace => __PACKAGE__,
); );
if (defined $flickr_verifier && $flickr_verifier) { if (defined $flickr_verifier && $flickr_verifier) {
@@ -516,7 +515,7 @@ sub FlickrTestLogin {
my $cache = CHI->new ( my $cache = CHI->new (
driver => 'BerkeleyDB', driver => 'BerkeleyDB',
root_dir => $cachedir, root_dir => $cachedir,
namespace => __PACKAGE__ namespace => __PACKAGE__,
); );
my $flickr_access_token = $cache->get ('flickr_access_token'); my $flickr_access_token = $cache->get ('flickr_access_token');
@@ -535,7 +534,7 @@ sub FlickrByTags {
my $cache = CHI->new ( my $cache = CHI->new (
driver => 'BerkeleyDB', driver => 'BerkeleyDB',
root_dir => $cachedir, root_dir => $cachedir,
namespace => __PACKAGE__ namespace => __PACKAGE__,
); );
my $flickr_access_token = $cache->get ('flickr_access_token'); my $flickr_access_token = $cache->get ('flickr_access_token');
@@ -568,7 +567,7 @@ sub FlickrByText {
my $cache = CHI->new ( my $cache = CHI->new (
driver => 'BerkeleyDB', driver => 'BerkeleyDB',
root_dir => $cachedir, root_dir => $cachedir,
namespace => __PACKAGE__ namespace => __PACKAGE__,
); );
my $flickr_access_token = $cache->get ('flickr_access_token'); my $flickr_access_token = $cache->get ('flickr_access_token');