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

Initial commit

Browse Source
This commit is contained in:
eleksir
2021-07-29 03:23:25 +03:00
committed by Sergei Fedosov
commit 1e0181a294
24 changed files with 2363 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10
.gitignore vendored Normal file
View File

@@ -0,0 +1,10 @@
_Deparsed_XSubs.pm
.idea/**
.vscode/**
.vstags
*.pid
*.log
data/cache/**
data/config.json
data/image/**
vendor_perl/**

95
.perlcriticrc Normal file
View File

@@ -0,0 +1,95 @@
#!/usr/bin/env perlcritic
severity = 5
verbose = 8
# minorify some of warnings that are not really critical
[-InputOutput::RequireCheckedClose]
# What can we handle in case of error?
[-Modules::ProhibitExcessMainComplexity]
# Noone cares
[-Subroutines::ProhibitExcessComplexity]
# Noone cares
[-Subroutines::ProhibitExplicitReturnUndef]
# But it's very handy sometimes!
[-ValuesAndExpressions::ProhibitMagicNumbers]
# this policy makes too much false positives
[-RegularExpressions::RequireLineBoundaryMatching]
# We use /m as needed
[-RegularExpressions::RequireExtendedFormatting]
# We do not use extended formatting of regex, they still not THAT complex
[-RegularExpressions::RequireDotMatchAnything]
# huh?
[-RegularExpressions::ProhibitEscapedMetacharacters]
# Looks like it pointless
[-ControlStructures::ProhibitCascadingIfElse]
# I like long if..else chains
[-ControlStructures::ProhibitPostfixControls]
# In short lines we can afford ourselves to use postfix controls
# but ofcorse we should avoid such constructions in long lines.
[-Subroutines::ProhibitSubroutinePrototypes]
# Contrary to Perl::Critic we consider prototypes as useful, even if
# the compile-time checks of Perl are not perfect, Perl may give some
# hints.
[-CodeLayout::RequireTidyCode]
# Impossible to complete, because of on higher linting levels "## no critic..."
# require be per-case on same line where critique is, but tidy align them
# one line down.
[-CodeLayout::ProhibitParensWithBuiltins]
# duh...
[-ValuesAndExpressions::ProhibitEmptyQuotes]
# cause we consider following correct and useful: my $var = '';
# the recomended use of q{} looks too complex: my $var = q{};
[-ValuesAndExpressions::ProhibitNoisyQuotes]
# Other people, other opinions: "," is better readable than qw(,)
[-BuiltinFunctions::ProhibitSleepViaSelect]
# We do not wish to use too much external modules.
# select undef, undef, undef, 0.25; # actually is okay if you add comment that
# it is sleep for 0.25 seconds
[-NamingConventions::Capitalization]
# duh...
# Noone care, really
[-ControlStructures::ProhibitUnlessBlocks]
# They should not be too complex - only one condition should be checked,
# that's all
[-Miscellanea::ProhibitTies]
# Just allow it. It's very handy stuff and extremely simple and safe enugh to use.
[-ValuesAndExpressions::RequireNumberSeparators]
# Not really
[-InputOutput::RequireBracedFileHandleWithPrint]
# We prefer not to use braced file handles
[-Documentation::PodSpelling]
# It doesn't help, but emits annoying errors
[Documentation::RequirePodSections]
# Considering this as "soft" requirement. For modules that is (or will be)
# stand-alone libs well formed documentation is highly desired.
lib_sections = NAME | VERSION | DESCRIPTION | AUTHOR | LICENSE AND COPYRIGHT
[-InputOutput::RequireBriefOpen]
# Yes, i do!
[-ControlStructures::ProhibitDeepNests]
# Have to use it, so fuckoff

127
LICENSE Normal file
View File

@@ -0,0 +1,127 @@
The "Artistic License"
Preamble
The intent of this document is to state the conditions under which a
Package may be copied, such that the Copyright Holder maintains some
semblance of artistic control over the development of the package,
while giving the users of the package the right to use and distribute
the Package in a more-or-less customary fashion, plus the right to make
reasonable modifications.
Definitions:
"Package" refers to the collection of files distributed by the
Copyright Holder, and derivatives of that collection of files
created through textual modification.
"Standard Version" refers to such a Package if it has not been
modified, or has been modified in accordance with the wishes
of the Copyright Holder as specified below.
"Copyright Holder" is whoever is named in the copyright or
copyrights for the package.
"You" is you, if you're thinking about copying or distributing
this Package.
"Reasonable copying fee" is whatever you can justify on the
basis of media cost, duplication charges, time of people involved,
and so on. (You will not be required to justify it to the
Copyright Holder, but only to the computing community at large
as a market that must bear the fee.)
"Freely Available" means that no fee is charged for the item
itself, though there may be fees involved in handling the item.
It also means that recipients of the item may redistribute it
under the same conditions they received it.
1. You may make and give away verbatim copies of the source form of the
Standard Version of this Package without restriction, provided that you
duplicate all of the original copyright notices and associated disclaimers.
2. You may apply bug fixes, portability fixes and other modifications
derived from the Public Domain or from the Copyright Holder. A Package
modified in such a way shall still be considered the Standard Version.
3. You may otherwise modify your copy of this Package in any way, provided
that you insert a prominent notice in each changed file stating how and
when you changed that file, and provided that you do at least ONE of the
following:
a) place your modifications in the Public Domain or otherwise make them
Freely Available, such as by posting said modifications to Usenet or
an equivalent medium, or placing the modifications on a major archive
site such as uunet.uu.net, or by allowing the Copyright Holder to include
your modifications in the Standard Version of the Package.
b) use the modified Package only within your corporation or organization.
c) rename any non-standard executables so the names do not conflict
with standard executables, which must also be provided, and provide
a separate manual page for each non-standard executable that clearly
documents how it differs from the Standard Version.
d) make other distribution arrangements with the Copyright Holder.
4. You may distribute the programs of this Package in object code or
executable form, provided that you do at least ONE of the following:
a) distribute a Standard Version of the executables and library files,
together with instructions (in the manual page or equivalent) on where
to get the Standard Version.
b) accompany the distribution with the machine-readable source of
the Package with your modifications.
c) give non-standard executables non-standard names, and clearly
document the differences in manual pages (or equivalent), together
with instructions on where to get the Standard Version.
d) make other distribution arrangements with the Copyright Holder.
5. You may charge a reasonable copying fee for any distribution of this
Package. You may charge any fee you choose for support of this
Package. You may not charge a fee for this Package itself. However,
you may distribute this Package in aggregate with other (possibly
commercial) programs as part of a larger (possibly commercial) software
distribution provided that you do not advertise this Package as a
product of your own. You may embed this Package's interpreter within
an executable of yours (by linking); this shall be construed as a mere
form of aggregation, provided that the complete Standard Version of the
interpreter is so embedded.
6. The scripts and library files supplied as input to or produced as
output from the programs of this Package do not automatically fall
under the copyright of this Package, but belong to whoever generated
them, and may be sold commercially, and may be aggregated with this
Package. If such scripts or library files are aggregated with this
Package via the so-called "undump" or "unexec" methods of producing a
binary executable image, then distribution of such an image shall
neither be construed as a distribution of this Package nor shall it
fall under the restrictions of Paragraphs 3 and 4, provided that you do
not represent such an executable image as a Standard Version of this
Package.
7. C subroutines (or comparably compiled subroutines in other
languages) supplied by you and linked into this Package in order to
emulate subroutines and variables of the language defined by this
Package shall not be considered part of this Package, but are the
equivalent of input as in Paragraph 6, provided these subroutines do
not change the language in any way that would cause it to fail the
regression tests for the language.
8. Aggregation of this Package with a commercial distribution is always
permitted provided that the use of this Package is embedded; that is,
when no overt attempt is made to make this Package's interfaces visible
to the end user of the commercial distribution. Such use shall not be
construed as a distribution of this Package.
9. The name of the Copyright Holder may not be used to endorse or promote
products derived from this software without specific prior written permission.
10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
The End

113
README Normal file
View File

@@ -0,0 +1,113 @@
aleesa-weba
------------------------------------------------------------------------------
Клиент для различных веб-приложений и API.
Работает по протоколу Redis pubsub.
Механика работы
------------------------------------------------------------------------------
Клиент подписан на все каналы, попадающие под шаблон "webapp:*" (без кавычек).
Предполагается, что есть специальный канал "broadcast", на который
подписываются все модули и, если надо, ответ в такой канал получают все.
Формат протокола - это json с полями:
from - модуль, который решил отправить запрос.
chatid - чат, из которого сделан вызов
userid - пользователь, на чью фразу мы отвечаем
message - оригинальный текст сообщения
plugin - плагин, нужный для генерации ответа
misc - объект с дополнительными полями, здесь все поля опциональны и
специфичны для задействованных плагинов
N.B.
При запуске нового приложения, которое будет пользоваться этим клиентом, оно
должно "поприветствовать" клиента по всем каналам, для того, чтобы сработала
внутренняя логика и клиент подписался на новые каналы. Если этого не сделать,
то первое сообщение по новому каналу будет "проглочено" и "потрачено" на
подписку на этот канал.
Плагины и команды
------------------------------------------------------------------------------
TBD: Описать список плагинов и команд, которые их триггерят.
Плагин для работы с flickr
------------------------------------------------------------------------------
Этот плагин используется для добычи ссылок на картинки в разных "картиночных"
командах бота.
Есть скрипт, который поможет с регистрацией приложения в api Flickr -
bin/flickr_init.pl он достанет все нужные ключи и секреты к ним.
До запуска этого скрипта, бот должен быть забутстраплен через bootstrap.sh.
Залогиньтесь 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" в конфиге либо закоменчен
либо отсутствует.
Далее, разлогиньтесь, это нужно, чтобы потом проще было достать параметр
verifier.
Запустите bin/flickr_init.pl и следуте предлагаемым инструкциям - в итоге
будет дана ссылка, которую надо скопипастить в браузер. По ссылке предложат
залогиниться, далее надо будет разрешить приложению просматривать профиль и
через один-два редиректа вы попадёте на example.com. Из адресной строки
браузера надо скопировать параметр "verifier" и вписать его в config.json.
Чтобы сохранить в бд плагина 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 предлагает всё необхдимое
для работы плагина.
Когда 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 и так далее.
В каталоге с приложением под целевым пользователем запускаем bash bootstrap.sh
Ждём с надеждой, что оно не обломится в пути.
Если всё хорошо, то после создания data/config.json из data/config_sample.json
и получения ключей и настройки модулей openweathermap и flickr, можно
запускать приложение. Оно запустится как unix daemon.
Тест
------------------------------------------------------------------------------
Версии перловых модулей в 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. Ошибок быть
не должно ни в консоли теста ни в логе, к которому мы притэйлились.
Если тесты работают не взрываясь - работает и приложение.

8
TODO Normal file
View File

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

194
bin/aleesa-weba Executable file
View File

@@ -0,0 +1,194 @@
#!/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");
no Cwd;
use Cwd::utf8 qw (chdir abs_path);
use File::Basename qw (basename dirname);
use File::Path qw (make_path);
use Log::Any qw ($log);
use Log::Any::Adapter;
use Log::Any::For::Std;
use POSIX qw (setgid setuid setsid);
use Conf qw (LoadConf);
use WebApp qw (RunWebApp);
sub daemonize;
sub __fork;
sub __signal_handler;
local $OUTPUT_AUTOFLUSH = 1;
my $runAsUid = $UID;
my $piddir = '/var/run/' . basename (abs_path ($PROGRAM_NAME));
my $C = LoadConf ();
my $loglevel = $C->{'loglevel'} // 'notice';
my $logfile;
if (defined $C->{'log'}) {
$logfile = $C->{'log'};
} elsif (defined $C->{'debug_log'}) {
$logfile = $C->{'debug_log'};
}
# if we run under root, create pid dir and set correct owner for it, same for debug log if it is defined
if ($UID == 0) {
my $user = $C->{user};
unless (defined $user) {
die "Unable to run as root, please define unprivileged user in config.json\n";
}
my ($uid, $gid) = (getpwnam $user)[2,3];
unless (-d $piddir) {
make_path (
$piddir, {
uid => $uid,
group => $gid
}
);
}
if (defined $logfile) {
my $logdir = dirname $logfile;
unless (-d $logdir) {
make_path (
$logdir, {
uid => $uid,
group => $gid
}
) or die "Unable to create $logdir: $OS_ERROR\n";
}
}
# drop privs
setgid ($gid) or die "Unable to switch to group of $user($OS_ERROR)\n";
setuid ($uid) or die "Unable to switch to account $user($OS_ERROR)\n";
} else {
$piddir = $workdir;
}
if (defined $logfile) {
Log::Any::Adapter->set ('File', $logfile, log_level => $loglevel);
# Some annoying CHI logging events come with category set to CHI::Driver and log_level set to debug.
# Until we use start using Log::Any native features and set whole loglevel accordingly, lets lower
# verbosity paticulary for CHI.
Log::Any::Adapter->set (
{
category => 'CHI::Driver'
},
'File',
$logfile,
log_level => 'warn'
);
} else {
Log::Any::Adapter->set ('File', '/dev/null');
}
# double fork attach to /dev/null all stdio and go background
#daemonize ();
# write pidfile
my $apath = abs_path $PROGRAM_NAME;
unless (defined $apath) {
$log->fatal ("[FATAL] Unable to get abs_path: $OS_ERROR\n");
exit 1;
};
# write pidfile
my $pidfile = sprintf '%s/%s.pid', $piddir, basename $apath;
$log->info ("[INFO] Creating pidfile at $pidfile");
open my $MYPID, '>', $pidfile or do {
$log->fatal ("[FATAL] Error opening $pidfile: $OS_ERROR");
exit 1;
};
print {$MYPID} $PID or do {
$log->fatal ("[FATAL] Error writing to $pidfile: $OS_ERROR");
exit 1;
};
close $MYPID; ## no critic (InputOutput::RequireCheckedSyscalls
local $SIG{INT} = \&__signal_handler;
local $SIG{TERM} = \&__signal_handler;
# set correct proctitle
$PROGRAM_NAME = abs_path $PROGRAM_NAME; ## no critic (Variables::RequireLocalizedPunctuationVars)
# run bot, at last
RunWebApp ();
if (-f $pidfile) {
unlink $pidfile;
}
exit 0;
sub daemonize {
__fork ();
POSIX::setsid ();
open STDIN, '<', '/dev/null'; ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
# 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 STDERR, '>', '/dev/null'; ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
__fork ();
umask 0;
return;
}
sub __fork {
my $pid = fork;
unless (defined $pid) {
$log->fatal ("[FATAL] Can't fork: $OS_ERROR");
exit 1;
}
if ($pid != 0) {
exit;
}
return;
}
sub __signal_handler {
$log->info ("[INFO] Caught a signal $OS_ERROR");
if (-f $pidfile) {
unlink $pidfile;
}
exit 0;
}
__END__
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

49
bin/test-pub.pl Executable file
View File

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

53
bin/test-sub.pl Executable file
View File

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

88
bin/test.pl Executable file
View File

@@ -0,0 +1,88 @@
#!/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;

5
bootstrap.sh Normal file
View File

@@ -0,0 +1,5 @@
#!/bin/bash
cpanm -l vendor_perl --self-contained --force --installdeps .
# vim: set ft=sh noet ai ts=4 sw=4 sts=4:

36
cpanfile Normal file
View File

@@ -0,0 +1,36 @@
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';

34
data/config_sample.json Normal file
View File

@@ -0,0 +1,34 @@
{
# server address
"server" : "redis",
"port" : "6379",
# where caches go there
"cachedir" : "data/cache",
# 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",
"loglevel": "notice",
# ditto
"pid" : "/var/run/aleesa-weba/aleesa-weba.pid",
"openweathermap" : {
"appid": "get_it_on_openweathermap.org"
},
"image": {
"dir" : "data/image",
"flickr" : {
"consumer_key" : "key",
"consumer_secret" : "key_secret",
"verifier": "verifier_key"
}
}
}

58
lib/Buni.pm Normal file
View File

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

40
lib/Conf.pm Normal file
View File

@@ -0,0 +1,40 @@
package Conf;
# loads config
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use JSON::XS;
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
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 $readlen = read $CH, $json, $len;
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);
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

124
lib/Drink.pm Normal file
View File

@@ -0,0 +1,124 @@
package Drink;
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Encode;
use CHI;
use CHI::Driver::BerkeleyDB;
use DateTime;
use HTTP::Tiny;
use HTML::TokeParser;
use Log::Any qw ($log);
use POSIX qw (strftime);
use Conf qw (LoadConf);
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (Drink);
my @MONTH = qw (yanvar fevral mart aprel may iyun iyul avgust sentyabr oktyabr noyabr dekabr);
my $c = LoadConf ();
sub Drink {
my $drinkCallBack = sub {
my $ret;
my ($dayNum, $monthNum) = (localtime ())[3, 4];
my $url = sprintf 'https://kakoysegodnyaprazdnik.ru/baza/%s/%s', $MONTH[$monthNum], $dayNum;
my $r;
for (1..3) {
my $http = HTTP::Tiny->new (timeout => 3);
$r = $http->get ($url, {'Accept-Charset' => 'utf-8', 'Accept-Language' => 'ru-RU'});
if ($r->{success}) {
last;
}
sleep 2;
}
if ($r->{success}) {
# TODO: Handle unexpected content
my $p = HTML::TokeParser->new (\$r->{content});
my @a;
my @holiday;
do {
$#a = -1;
@a = $p->get_tag ('span'); ## no critic (Variables::RequireLocalizedPunctuationVars)
if ($#{$a[0]} > 2 && defined $a[0][1]->{itemprop} && $a[0][1]->{itemprop} eq 'text') {
push @holiday,'* ' . decode ('UTF-8', $p->get_trimmed_text ('/span'));
}
} while ($#{$a[0]} > 1);
if ($#holiday > 0) {
# cut off something weird, definely not a "holyday"
$#holiday = $#holiday - 1;
}
if ($#holiday > 0) {
$ret = join "\n", @holiday;
}
} else {
$log->warn (sprintf '[WARN] Server return status %s with message: %s', $r->{status}, $r->{reason});
return undef;
}
return $ret;
};
my $cache = CHI->new (
driver => 'BerkeleyDB',
root_dir => $c->{cachedir},
namespace => __PACKAGE__
);
# Those POSIX assholes just forgot to add unix timestamps without TZ offset, so...
my ($mday, $mon, $year) = (gmtime ())[3, 4, 5];
my $offset = strftime ('%z', gmtime ());
my $offsetMinutes = (substr $offset, -2) * 60;
my $offsetHours = (substr $offset, 1, 2) * 60 * 60;
my $offsetSign;
if ((substr $offset, 0, 1) eq '+') {
$offsetSign = 1;
}
my $expirationDate = DateTime->new (
year => $year + 1900,
month => $mon + 1,
day => $mday,
hour => 0,
minute => 0,
second => 0
)->add (days => 1)->strftime ('%s');
if ((substr $offset, 0, 1) eq '+') {
$expirationDate = $expirationDate - $offsetHours - $offsetMinutes;
} else {
$expirationDate = $expirationDate + $offsetHours + $offsetMinutes;
}
# Okay, now we have correct unix timestamp, heh
my $res = $cache->compute (
'Holiday',
{ expires_at => $expirationDate },
$drinkCallBack
);
if (defined $res && $res ne '') {
return $res;
} else {
return 'Не знаю праздников - вджобываю весь день на шахтах, как проклятая.';
}
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

54
lib/Fox.pm Normal file
View File

@@ -0,0 +1,54 @@
package Fox;
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use JSON::XS;
use HTTP::Tiny;
use Log::Any qw ($log);
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (Fox);
sub Fox {
my $r;
my $ret = 'Нету лисичек, все разбежались.';
for (1..3) {
my $http = HTTP::Tiny->new (timeout => 3);
$r = $http->get ('https://randomfox.ca/floof/');
if ($r->{success}) {
last;
}
sleep 2;
}
if ($r->{success}) {
my $jfox = eval {
decode_json ($r->{content})
};
unless (defined $jfox) {
$log->warn ("[WARN] Unable to decode JSON: $EVAL_ERROR");
} else {
if ($jfox->{image}) {
$jfox->{image} =~ s/\\//xmsg;
$ret = $jfox->{image};
}
}
} else {
$log->warn (sprintf '[WARN] Server return status %s with message: %s', $r->{status}, $r->{reason});
}
return $ret;
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

70
lib/Image.pm Normal file
View File

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

640
lib/Image/Flickr.pm Normal file
View File

@@ -0,0 +1,640 @@
package Image::Flickr;
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Carp qw (cluck);
use 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 URI::Encode::XS qw (uri_encode);
use Conf qw (LoadConf);
use Util qw (urlencode);
use Data::Dumper;
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (FlickrInit FlickrByTags FlickrByText FlickrTestLogin);
my $c = LoadConf ();
my $dir = $c->{image}->{dir};
my $flickr_consumer_key = $c->{image}->{flickr}->{consumer_key};
my $flickr_consumer_secret = $c->{image}->{flickr}->{consumer_secret};
my $flickr_verifier = $c->{image}->{flickr}->{verifier};
my $flickr_request_token_url = 'https://www.flickr.com/services/oauth/request_token';
my $flickr_authorization_url = 'https://www.flickr.com/services/oauth/authorize';
my $flickr_access_token_url = 'https://www.flickr.com/services/oauth/access_token';
my $flickr_callback_url = 'http://www.example.com';
my $flickr_api_url = 'https://www.flickr.com/services/rest/';
sub mknonce {
# make random number, 8 symbols in length
my $nonce = sprintf '%08d', irand (99999999);
return $nonce;
}
sub flickrSignReq {
my %p = @_;
my $string;
my $hmac;
if ($p{type} eq 'request_token') {
my @parameters;
delete $p{type};
push @parameters, 'oauth_signature_method=HMAC-SHA1';
push @parameters, 'oauth_version=1.0';
push @parameters, sprintf 'oauth_callback=%s', uri_encode ($flickr_callback_url);
push @parameters, sprintf 'oauth_consumer_key=%s', $flickr_consumer_key;
foreach my $param (keys %p) {
push @parameters, sprintf ('%s=%s', $param, $p{$param});
}
$string = sprintf 'GET&%s&', uri_encode ($flickr_request_token_url);
$string .= uri_encode (join '&', sort (@parameters));
# Thanks to twitter api dev portal, they explain this particular case: while we requesting this token
# we do not yet know access_token secret, so we just omit it in this signature
# https://developer.twitter.com/en/docs/authentication/oauth-1-0a/creating-a-signature
$hmac = Digest::HMAC_SHA1->new (sprintf '%s&', uri_encode ($flickr_consumer_secret));
} elsif ($p{type} eq 'access_token') {
my @parameters;
my $flickr_request_token_secret = $p{oauth_token_secret};
delete $p{oauth_token_secret};
delete $p{type};
push @parameters, 'oauth_signature_method=HMAC-SHA1';
push @parameters, 'oauth_version=1.0';
push @parameters, sprintf 'oauth_consumer_key=%s', $flickr_consumer_key;
foreach my $param (keys %p) {
push @parameters, sprintf ('%s=%s', $param, $p{$param});
}
$string = sprintf 'GET&%s&', uri_encode ($flickr_access_token_url);
$string .= uri_encode (join '&', sort (@parameters));
$hmac = Digest::HMAC_SHA1->new (sprintf '%s&%s', uri_encode ($flickr_consumer_secret), uri_encode ($flickr_request_token_secret));
} elsif ($p{type} eq 'test_login' || $p{type} eq 'search_text' || $p{type} eq 'search_tags') {
my @parameters;
my $flickr_request_token_secret = $p{oauth_token_secret};
delete $p{oauth_token_secret};
delete $p{type};
foreach my $param (keys %p) {
push @parameters, sprintf ('%s=%s', $param, $p{$param});
}
$string = sprintf 'GET&%s&', uri_encode ($flickr_api_url);
$string .= uri_encode (join '&', sort (@parameters));
$hmac = Digest::HMAC_SHA1->new (sprintf '%s&%s', uri_encode ($flickr_consumer_secret), uri_encode ($flickr_request_token_secret));
}
$hmac->add ($string);
return encode_base64 ($hmac->digest, '');
}
sub flickrRequestToken {
my $oauth_timestamp = time ();
my $oauth_nonce = mknonce ();
my $oauth_signature = flickrSignReq (
type => 'request_token',
oauth_timestamp => $oauth_timestamp,
oauth_nonce => $oauth_nonce
);
my $url = $flickr_request_token_url . sprintf (
'?oauth_nonce=%s&oauth_timestamp=%s&oauth_consumer_key=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&&oauth_signature=%s&oauth_callback=%s',
$oauth_nonce,
$oauth_timestamp,
$flickr_consumer_key,
uri_encode ($oauth_signature),
uri_encode ($flickr_callback_url)
);
my $http = HTTP::Tiny->new (timeout => 5);
my $r = $http->get ($url);
my %params;
if ($r->{success}) {
# they ignore format=json, so...
%params = map {split /=/} split /&/, $r->{content};
} else {
say "Something bad returns from flickr api: $r->{status} $r->{content}"; ## no critic (InputOutput::RequireCheckedSyscalls)
}
return %params;
}
sub flickrAccessToken {
my $flickr_request_token = shift;
my $flickr_request_token_secret = shift;
my $flickr_verifier = shift; ## no critic (Variables::ProhibitReusedNames)
my $oauth_timestamp = time ();
my $oauth_nonce = mknonce ();
my $oauth_signature = flickrSignReq (
type => 'access_token',
oauth_timestamp => $oauth_timestamp,
oauth_nonce => $oauth_nonce,
oauth_token => $flickr_request_token,
oauth_token_secret => $flickr_request_token_secret,
oauth_verifier => $flickr_verifier
);
my $url = $flickr_access_token_url . sprintf (
'?oauth_nonce=%s&oauth_timestamp=%s&oauth_verifier=%s&oauth_consumer_key=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s',
$oauth_nonce,
$oauth_timestamp,
$flickr_verifier,
$flickr_consumer_key,
$flickr_request_token,
uri_encode ($oauth_signature)
);
my $http = HTTP::Tiny->new (timeout => 5);
my $r = $http->get ($url);
my %params;
if ($r->{success}) {
# they ignore format=json
%params = map {split /=/} split /&/, $r->{content};
} else {
say "Something bad returns from flickr api: $r->{status} $r->{content}"; ## no critic (InputOutput::RequireCheckedSyscalls)
}
return %params;
}
sub flickrAuthorization {
my $flickr_request_token = shift;
my $url = $flickr_authorization_url . sprintf (
'?oauth_token=%s&perms=read',
$flickr_request_token,
);
my $http = HTTP::Tiny->new (timeout => 5);
my $r = $http->get ($url);
if ($r->{success}) {
return $r->{url};
} else {
say "Something went wrong: $r->{status} $r->{content}"; ## no critic (InputOutput::RequireCheckedSyscalls)
return;
}
}
sub flickrTestLogin {
my $flickr_access_token = shift;
my $flickr_access_token_secret = shift;
my $oauth_timestamp = time ();
my $oauth_nonce = mknonce ();
my $oauth_signature = flickrSignReq (
nojsoncallback => 1,
oauth_nonce => $oauth_nonce,
format => 'json',
oauth_consumer_key => $flickr_consumer_key,
oauth_timestamp => $oauth_timestamp,
type => 'test_login',
method => 'flickr.test.login',
oauth_token => $flickr_access_token,
oauth_token_secret => $flickr_access_token_secret,
oauth_signature_method => 'HMAC-SHA1',
oauth_version => '1.0'
);
my $url = $flickr_api_url . sprintf (
'?nojsoncallback=1&oauth_nonce=%s&format=json&oauth_consumer_key=%s&oauth_timestamp=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s&method=flickr.test.login',
$oauth_nonce,
$flickr_consumer_key,
$oauth_timestamp,
$flickr_access_token,
uri_encode ($oauth_signature)
);
my $http = HTTP::Tiny->new (timeout => 5);
my $r = $http->get ($url);
if ($r->{success}) {
my $response = eval {
my $j = JSON::XS->new->utf8->relaxed;
return $j->decode ($r->{content});
};
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)
return 0;
}
} else {
say "HTTP status code not 200: $r->{status}, $r>{contenr}"; ## no critic (InputOutput::RequireCheckedSyscalls)
return 0;
}
}
sub flickrSearchByText {
my $flickr_access_token = shift;
my $flickr_access_token_secret = shift;
my $text = shift;
my $oauth_timestamp = time ();
my $oauth_nonce = mknonce ();
my $oauth_signature = flickrSignReq (
nojsoncallback => 1,
oauth_nonce => $oauth_nonce,
format => 'json',
oauth_consumer_key => $flickr_consumer_key,
oauth_timestamp => $oauth_timestamp,
type => 'search_text',
content_type => 1,
media => 'photos',
method => 'flickr.photos.search',
text => $text,
per_page => 1,
oauth_token => $flickr_access_token,
oauth_token_secret => $flickr_access_token_secret,
oauth_signature_method => 'HMAC-SHA1',
oauth_version => '1.0'
);
my $url = $flickr_api_url . sprintf (
'?nojsoncallback=1&oauth_nonce=%s&format=json&oauth_consumer_key=%s&oauth_timestamp=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s&method=flickr.photos.search&content_type=1&media=photos&per_page=1&text=%s',
$oauth_nonce,
$flickr_consumer_key,
$oauth_timestamp,
$flickr_access_token,
uri_encode ($oauth_signature),
uri_encode ($text)
);
my $http = HTTP::Tiny->new (timeout => 5);
my $r = $http->get ($url);
if ($r->{success}) {
my $response = eval {
my $j = JSON::XS->new->utf8->relaxed;
return $j->decode ($r->{content});
};
if (defined $response) {
# lets make another query, this time with random picture
my $page = irand (int $response->{photos}->{total} / 500);
$oauth_timestamp = time ();
$oauth_nonce = mknonce ();
$oauth_signature = flickrSignReq (
nojsoncallback => 1,
oauth_nonce => $oauth_nonce,
format => 'json',
oauth_consumer_key => $flickr_consumer_key,
oauth_timestamp => $oauth_timestamp,
type => 'search_text',
content_type => 1,
media => 'photos',
method => 'flickr.photos.search',
text => $text,
page => $page,
per_page => 500,
oauth_token => $flickr_access_token,
oauth_token_secret => $flickr_access_token_secret,
oauth_signature_method => 'HMAC-SHA1',
oauth_version => '1.0'
);
$url = $flickr_api_url . sprintf (
'?nojsoncallback=1&oauth_nonce=%s&format=json&oauth_consumer_key=%s&oauth_timestamp=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s&method=flickr.photos.search&content_type=1&media=photos&per_page=500&page=%d&text=%s',
$oauth_nonce,
$flickr_consumer_key,
$oauth_timestamp,
$flickr_access_token,
uri_encode ($oauth_signature),
$page,
uri_encode ($text)
);
$http = HTTP::Tiny->new (timeout => 5);
$r = $http->get ($url);
if ($r->{success}) {
$response = eval {
my $j = JSON::XS->new->utf8->relaxed;
return $j->decode ($r->{content});
};
if (defined $response) {
return $response;
} else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
return undef;
}
} else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
return undef;
}
} else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
return undef;
}
} else {
$log->warn ("[WARN] HTTP status code not 200: $r->{status}, $r->{content}");
return undef;
}
}
sub flickrSearchByTags {
my $flickr_access_token = shift;
my $flickr_access_token_secret = shift;
my $tags = shift;
my $oauth_timestamp = time ();
my $oauth_nonce = mknonce ();
my $oauth_signature = flickrSignReq (
nojsoncallback => 1,
oauth_nonce => $oauth_nonce,
format => 'json',
oauth_consumer_key => $flickr_consumer_key,
oauth_timestamp => $oauth_timestamp,
type => 'search_tags',
content_type => 1,
media => 'photos',
method => 'flickr.photos.search',
tags => $tags,
per_page => 1,
oauth_token => $flickr_access_token,
oauth_token_secret => $flickr_access_token_secret,
oauth_signature_method => 'HMAC-SHA1',
oauth_version => '1.0'
);
my $url = $flickr_api_url . sprintf (
'?nojsoncallback=1&oauth_nonce=%s&format=json&oauth_consumer_key=%s&oauth_timestamp=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s&method=flickr.photos.search&content_type=1&media=photos&per_page=1&tags=%s&tag_mode=all',
$oauth_nonce,
$flickr_consumer_key,
$oauth_timestamp,
$flickr_access_token,
uri_encode ($oauth_signature),
uri_encode ($tags)
);
my $http = HTTP::Tiny->new (timeout => 5);
my $r = $http->get ($url);
if ($r->{success}) {
my $response = eval {
my $j = JSON::XS->new->utf8->relaxed;
return $j->decode ($r->{content});
};
if (defined $response) {
# lets make another query, this time with random picture
my $page = irand int ($response->{photos}->{total} / 500);
$oauth_timestamp = time ();
$oauth_nonce = mknonce ();
$oauth_signature = flickrSignReq (
nojsoncallback => 1,
oauth_nonce => $oauth_nonce,
format => 'json',
oauth_consumer_key => $flickr_consumer_key,
oauth_timestamp => $oauth_timestamp,
type => 'search_text',
content_type => 1,
media => 'photos',
method => 'flickr.photos.search',
tags => $tags,
page => $page,
per_page => 500,
oauth_token => $flickr_access_token,
oauth_token_secret => $flickr_access_token_secret,
oauth_signature_method => 'HMAC-SHA1',
oauth_version => '1.0'
);
$url = $flickr_api_url . sprintf (
'?nojsoncallback=1&oauth_nonce=%s&format=json&oauth_consumer_key=%s&oauth_timestamp=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s&method=flickr.photos.search&content_type=1&media=photos&per_page=500&page=%d&tags=%s&tag_mode=all',
$oauth_nonce,
$flickr_consumer_key,
$oauth_timestamp,
$flickr_access_token,
uri_encode ($oauth_signature),
$page,
uri_encode ($tags)
);
$http = HTTP::Tiny->new (timeout => 5);
$r = $http->get ($url);
if ($r->{success}) {
$response = eval {
my $j = JSON::XS->new->utf8->relaxed;
return $j->decode ($r->{content});
};
if (defined $response) {
return $response;
} else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
return undef;
}
} else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
return undef;
}
} else {
$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
return undef;
}
} else {
$log->warn ("[WARN] HTTP status code not 200: $r->{status}, $r>{content}");
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;
};
if (defined $flickr_verifier && $flickr_verifier) {
my $flickr_request_token = $secret{flickr_request_token};
my $flickr_request_token_secret = $secret{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;
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};
say sprintf ( ## no critic (InputOutput::RequireCheckedSyscalls)
'Access token (%s) and access token secret (%s) are in %s',
$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};
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;
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;
if (flickrTestLogin ($flickr_access_token, $flickr_access_token_secret)) {
return 1;
} else {
return 0;
}
}
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;
};
}
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;
# NB: I honestly query random page (among number of pages) of results from api, but always got first page,
# no matter what is shown in response' "page" parameter. Looks like bug in API. Try to little bit mitigate
# this bug via query 500 results per page, then we can select random result in this heap. But anyway, let's
# make this thing future proof and leave randomizer in page select.
my $result = flickrSearchByTags ($flickr_access_token, $flickr_access_token_secret, $text);
if ($result) {
if (defined ($result->{photos}) && defined ($result->{photos}->{photo})) {
my $item = irand int @{$result->{photos}->{photo}};
$item = ${$result->{photos}->{photo}}[$item];
$item = sprintf 'https://live.staticflickr.com/%s/%s_%s_z.jpg', $item->{server}, $item->{id}, $item->{secret};
return $item;
} else {
$log->notice ('[NOTICE] Flickr api returns empty search result list');
return;
}
} else {
return;
}
}
sub FlickrByText {
my $text = shift;
my $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;
};
}
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;
# NB: I honestly query random page (among number of pages) of results from api, but always got first page,
# no matter what is shown in response' "page" parameter. Looks like bug in API. Try to little bit mitigate
# this bug via query 500 results per page, then we can select random result in this heap. But anyway, let's
# make this thing future proof and leave randomizer in page select.
my $result = flickrSearchByText ($flickr_access_token, $flickr_access_token_secret, $text);
if ($result) {
if (defined ($result->{photos}) && defined ($result->{photos}->{photo})) {
my $item = irand (int (@{$result->{photos}->{photo}}));
$item = ${$result->{photos}->{photo}}[$item];
$item = sprintf 'https://live.staticflickr.com/%s/%s_%s_z.jpg', $item->{server}, $item->{id}, $item->{secret};
return $item;
} else {
$log->notice ('[NOTICE] Flickr api returns empty search result list');
return;
}
} else {
return;
}
}
1;

53
lib/Kitty.pm Normal file
View File

@@ -0,0 +1,53 @@
package Kitty;
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use JSON::XS;
use HTTP::Tiny;
use Log::Any qw ($log);
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (Kitty);
sub Kitty {
my $r;
my $ret = 'Нету кошечек, все разбежались.';
for (1..3) {
my $http = HTTP::Tiny->new (timeout => 3);
$r = $http->get ('https://api.thecatapi.com/v1/images/search');
if ($r->{success}) {
last;
}
sleep 2;
}
if ($r->{success}) {
my $jcat = eval {
decode_json ($r->{content})
};
unless (defined $jcat) {
$log->error ("[ERROR] Unable to decode JSON: $EVAL_ERROR");
} else {
if ($jcat->[0]->{url}) {
$ret = $jcat->[0]->{url};
}
}
} else {
$log->error (sprintf 'Server return status %s with message: %s', $r->{status}, $r->{reason});
}
return $ret;
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

62
lib/Monkeyuser.pm Normal file
View File

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

116
lib/Util.pm Normal file
View File

@@ -0,0 +1,116 @@
package Util;
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Carp qw (cluck);
use Digest::SHA qw (sha1_base64);
use Encode;
use MIME::Base64;
use Text::Fuzzy qw (distance_edits);
use URI::URL;
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (trim urlencode fmatch utf2b64 utf2sha1);
sub trim {
my $str = shift;
unless (defined $str) {
cluck '[ERROR] Str is undefined';
return '';
}
if ($str eq '') {
return $str;
}
while (substr ($str, 0, 1) =~ /^\s$/xms) {
$str = substr $str, 1;
}
while (substr ($str, -1, 1) =~ /^\s$/xms) {
chop $str;
}
return $str;
}
sub urlencode {
my $str = shift;
unless (defined $str) {
cluck '[ERROR] Str is undefined';
return '';
}
my $urlobj = url $str;
return $urlobj->as_string;
}
sub fmatch {
my $srcphrase = shift;
my $answer = shift;
if ((! defined $srcphrase) || (! defined $answer)) {
if (defined $srcphrase) {
cluck '[ERROR] Answer undefined';
} elsif (defined $answer) {
cluck '[ERROR] Srcphrase undefined';
} else {
cluck '[ERROR] Both srcphrase and answer are undefined';
}
return 0;
}
my ($distance, undef) = distance_edits ($srcphrase, $answer);
my $srcphraselen = length $srcphrase;
my $distance_max = int ($srcphraselen - ($srcphraselen * (100 - (90 / ($srcphraselen ** 0.5))) * 0.01));
if ($distance >= $distance_max) {
return 0;
} else {
return 1;
}
}
sub utf2b64 {
my $string = shift;
unless (defined $string) {
cluck '[ERROR] String is undefined';
return sha1_base64 '';
}
if ($string eq '') {
return encode_base64 '';
}
my $bytes = encode_utf8 $string;
return encode_base64 $bytes;
}
sub utf2sha1 {
my $string = shift;
unless (defined $string) {
cluck '[ERROR] String is undefined';
return sha1_base64 '';
}
if ($string eq '') {
return sha1_base64 '';
}
my $bytes = encode_utf8 $string;
return sha1_base64 $bytes;
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

177
lib/Weather.pm Normal file
View File

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

115
lib/WebApp.pm Normal file
View File

@@ -0,0 +1,115 @@
package WebApp;
# общие модули - синтаксис, кодировки итд
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
# модули для работы приложения
use Log::Any qw ($log);
use Mojo::Redis;
use Mojo::IOLoop;
# плагины web-клиентов
use Buni qw (Buni);
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 version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (RunWebApp);
my $c = LoadConf ();
# основной парсер
my $parse_message = sub {
my $self = shift;
my $m = shift;
my $answer = $m;
my $send_to = $answer->{from};
if (substr ($m->{message}, 1) eq 'buni') {
$answer->{message} = Buni ();
} elsif (substr ($m->{message}, 1) eq 'cat' || substr ($m->{message}, 1) eq 'кис') {
$answer->{message} = Kitty ();
} elsif (substr ($m->{message}, 1) eq 'drink' || substr ($m->{message}, 1) eq 'праздник') {
$answer->{message} = Drink ();
} elsif (substr ($m->{message}, 1) eq 'fox' || substr ($m->{message}, 1) eq 'лис') {
$answer->{message} = Fox ();
} elsif (substr ($m->{message}, 1) eq 'frog' || substr ($m->{message}, 1) eq 'лягушка') {
$answer->{message} = Frog ();
} elsif (substr ($m->{message}, 1) eq 'horse' || substr ($m->{message}, 1) eq 'лошадь' || substr ($m->{message}, 1) eq 'лошадка') {
$answer->{message} = Horse ();
} elsif (substr ($m->{message}, 1) eq 'monkeyuser') {
$answer->{message} = Monkeyuser ();
} elsif (substr ($m->{message}, 1) eq 'owl' || substr ($m->{message}, 1) eq 'сова' || substr ($m->{message}, 1) eq 'сыч') {
$answer->{message} = Owl ();
} elsif (substr ($m->{message}, 1) eq 'rabbit' || substr ($m->{message}, 1) eq 'bunny' || substr ($m->{message}, 1) eq 'кролик') {
$answer->{message} = Rabbit ();
} elsif (substr ($m->{message}, 1) eq 'snail' || substr ($m->{message}, 1) eq 'улитка') {
$answer->{message} = Snail ();
} elsif (substr ($m->{message}, 1) eq 'xkcd') {
$answer->{message} = 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);
} 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}
}
);
return;
};
# main loop, он же event loop
sub RunWebApp {
my $redis = Mojo::Redis->new (
sprintf 'redis://%s:%s/1', $c->{server}, $c->{port}
);
my $pubsub = $redis->pubsub;
my $sub;
$pubsub->listen (
# Вот такая ебическая конструкция для авто-подписывания на все новые каналы.
# Странное ограничение, при котором на шаблон каналов можно подписаться только, подписавшись на каждый из
# каналов. То есть подписка создаётся по запросу. В AnyEvent::Redis подписаться можно сразу на * :(
# Но конкретно в моём случае этот момент неважен, т.к. подразумевается, что каналы будут добавляться, но не
# будут убавляться.
'webapp:*' => sub {
my ($ps, $channel) = @_ ;
unless (defined $sub->{$channel}) {
$log->info ("Subscribing to $channel");
$sub->{$channel} = $ps->json ($channel)->listen (
$channel => sub { $parse_message->(@_); }
);
}
}
);
do { Mojo::IOLoop->start } until Mojo::IOLoop->is_running;
return;
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

42
lib/Xkcd.pm Normal file
View File

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