commit 1e0181a2943952a62929c1a69ae335293a23fed4 Author: eleksir Date: Thu Jul 29 03:23:25 2021 +0300 Initial commit diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..70ed190 --- /dev/null +++ b/.gitignore @@ -0,0 +1,10 @@ +_Deparsed_XSubs.pm +.idea/** +.vscode/** +.vstags +*.pid +*.log +data/cache/** +data/config.json +data/image/** +vendor_perl/** diff --git a/.perlcriticrc b/.perlcriticrc new file mode 100644 index 0000000..41f004d --- /dev/null +++ b/.perlcriticrc @@ -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 + diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..4ff3f42 --- /dev/null +++ b/LICENSE @@ -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 diff --git a/README b/README new file mode 100644 index 0000000..727ae9e --- /dev/null +++ b/README @@ -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. Ошибок быть +не должно ни в консоли теста ни в логе, к которому мы притэйлились. + +Если тесты работают не взрываясь - работает и приложение. diff --git a/TODO b/TODO new file mode 100644 index 0000000..97f8832 --- /dev/null +++ b/TODO @@ -0,0 +1,8 @@ +Приоритетные задачи: +Нет + +Неприоритетные задачи: +* В парсере обрабатывать параметр plugin. + Формально, клиенты не должны знать, как работает этот чёрный ящик. Послал + сообщение - получил ответ, а уж как он там получается - это неважно. Тем не + менее возможность напрямую дёрнуть один из плагинов должна быть. diff --git a/bin/aleesa-weba b/bin/aleesa-weba new file mode 100755 index 0000000..bb25eaa --- /dev/null +++ b/bin/aleesa-weba @@ -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: diff --git a/bin/test-pub.pl b/bin/test-pub.pl new file mode 100755 index 0000000..a8e6195 --- /dev/null +++ b/bin/test-pub.pl @@ -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; diff --git a/bin/test-sub.pl b/bin/test-sub.pl new file mode 100755 index 0000000..d0608ee --- /dev/null +++ b/bin/test-sub.pl @@ -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; diff --git a/bin/test.pl b/bin/test.pl new file mode 100755 index 0000000..bbfeffd --- /dev/null +++ b/bin/test.pl @@ -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; diff --git a/bootstrap.sh b/bootstrap.sh new file mode 100644 index 0000000..eb5740a --- /dev/null +++ b/bootstrap.sh @@ -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: diff --git a/cpanfile b/cpanfile new file mode 100644 index 0000000..7834965 --- /dev/null +++ b/cpanfile @@ -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'; diff --git a/data/config_sample.json b/data/config_sample.json new file mode 100644 index 0000000..520be4e --- /dev/null +++ b/data/config_sample.json @@ -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" + } + } +} diff --git a/lib/Buni.pm b/lib/Buni.pm new file mode 100644 index 0000000..5fee90a --- /dev/null +++ b/lib/Buni.pm @@ -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: diff --git a/lib/Conf.pm b/lib/Conf.pm new file mode 100644 index 0000000..38f8860 --- /dev/null +++ b/lib/Conf.pm @@ -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: diff --git a/lib/Drink.pm b/lib/Drink.pm new file mode 100644 index 0000000..a084770 --- /dev/null +++ b/lib/Drink.pm @@ -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: diff --git a/lib/Fox.pm b/lib/Fox.pm new file mode 100644 index 0000000..f0997fb --- /dev/null +++ b/lib/Fox.pm @@ -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: diff --git a/lib/Image.pm b/lib/Image.pm new file mode 100644 index 0000000..6596c90 --- /dev/null +++ b/lib/Image.pm @@ -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: diff --git a/lib/Image/Flickr.pm b/lib/Image/Flickr.pm new file mode 100644 index 0000000..aa5401b --- /dev/null +++ b/lib/Image/Flickr.pm @@ -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; diff --git a/lib/Kitty.pm b/lib/Kitty.pm new file mode 100644 index 0000000..a47a130 --- /dev/null +++ b/lib/Kitty.pm @@ -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: diff --git a/lib/Monkeyuser.pm b/lib/Monkeyuser.pm new file mode 100644 index 0000000..fa2f034 --- /dev/null +++ b/lib/Monkeyuser.pm @@ -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: diff --git a/lib/Util.pm b/lib/Util.pm new file mode 100644 index 0000000..c51f0b2 --- /dev/null +++ b/lib/Util.pm @@ -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: diff --git a/lib/Weather.pm b/lib/Weather.pm new file mode 100644 index 0000000..5176a63 --- /dev/null +++ b/lib/Weather.pm @@ -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: diff --git a/lib/WebApp.pm b/lib/WebApp.pm new file mode 100644 index 0000000..f434193 --- /dev/null +++ b/lib/WebApp.pm @@ -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: diff --git a/lib/Xkcd.pm b/lib/Xkcd.pm new file mode 100644 index 0000000..1515bfa --- /dev/null +++ b/lib/Xkcd.pm @@ -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: