Initial commit
This commit is contained in:
eleksir
10
.gitignore
vendored
Normal file
10
.gitignore
vendored
Normal 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
95
.perlcriticrc
Normal 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
127
LICENSE
Normal 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
113
README
Normal 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
8
TODO
Normal file
@@ -0,0 +1,8 @@
|
|||||||
|
Приоритетные задачи:
|
||||||
|
Нет
|
||||||
|
|
||||||
|
Неприоритетные задачи:
|
||||||
|
* В парсере обрабатывать параметр plugin.
|
||||||
|
Формально, клиенты не должны знать, как работает этот чёрный ящик. Послал
|
||||||
|
сообщение - получил ответ, а уж как он там получается - это неважно. Тем не
|
||||||
|
менее возможность напрямую дёрнуть один из плагинов должна быть.
|
||||||
194
bin/aleesa-weba
Executable file
194
bin/aleesa-weba
Executable 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
49
bin/test-pub.pl
Executable 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
53
bin/test-sub.pl
Executable 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
88
bin/test.pl
Executable 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
5
bootstrap.sh
Normal 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
36
cpanfile
Normal 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
34
data/config_sample.json
Normal 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
58
lib/Buni.pm
Normal 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
40
lib/Conf.pm
Normal 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
124
lib/Drink.pm
Normal 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
54
lib/Fox.pm
Normal 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
70
lib/Image.pm
Normal 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
640
lib/Image/Flickr.pm
Normal 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
53
lib/Kitty.pm
Normal 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
62
lib/Monkeyuser.pm
Normal 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
116
lib/Util.pm
Normal 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
177
lib/Weather.pm
Normal 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
115
lib/WebApp.pm
Normal 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
42
lib/Xkcd.pm
Normal 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:
|
||||||
Reference in New Issue
Block a user