[WIP] Initial commit
This commit is contained in:
Sergei Fedosov
462
lib/IRCApp.pm
Normal file
462
lib/IRCApp.pm
Normal file
@@ -0,0 +1,462 @@
|
||||
package IRCApp;
|
||||
# TODO: настроить в логгировании loglevel, всякие [ERRO] [WARN] [INFO] итд
|
||||
# общие модули - синтаксис, кодировки итд
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw (:std :utf8);
|
||||
|
||||
# модули для работы приложения
|
||||
use Date::Format::ISO8601 qw (gmtime_to_iso8601_datetime);
|
||||
use Log::Any qw ($log);
|
||||
use Mojo::Redis;
|
||||
use Mojo::IOLoop;
|
||||
use Mojo::IRC;
|
||||
use Data::Dumper;
|
||||
|
||||
use Conf qw (LoadConf);
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (RunIRCApp);
|
||||
|
||||
my $c = LoadConf ();
|
||||
my $identified = 0;
|
||||
|
||||
# основной парсер
|
||||
my $parse_redis_message = sub {
|
||||
my $self = shift;
|
||||
my $m = shift;
|
||||
my $answer = $m;
|
||||
my $send_to = $answer->{from};
|
||||
|
||||
$self->json ($send_to)->notify (
|
||||
$send_to => {
|
||||
from => $answer->{from},
|
||||
userid => $answer->{userid},
|
||||
chatid => $answer->{chatid},
|
||||
plugin => $answer->{plugin},
|
||||
message => $answer->{message}
|
||||
}
|
||||
);
|
||||
|
||||
return;
|
||||
};
|
||||
|
||||
my $on_irc_privmsg = sub {
|
||||
my $self = shift;
|
||||
my $m = shift;
|
||||
|
||||
my $reply;
|
||||
|
||||
if (substr ($text, 1, 3) eq 'rum' || substr ($text, 1, 3) eq 'ром') {
|
||||
my $target;
|
||||
|
||||
if ((length ($text) > 5)) {
|
||||
$target = trim (substr $text, 5);
|
||||
}
|
||||
|
||||
if (! defined $target || ($target eq '')) {
|
||||
$target = $chattername;
|
||||
}
|
||||
|
||||
$reply = 'притаскивает на подносе стопку рома для ' . $target . ', края стопки искрятся кристаллами соли.';
|
||||
$bot->send_long_message ('utf8', 0, "PRIVMSG\001ACTION", $chatid, $reply);
|
||||
return;
|
||||
} elsif (substr ($text, 1, 5) eq 'vodka' || substr ($text, 1, 5) eq 'водка') {
|
||||
my $target;
|
||||
|
||||
if ((length ($text) > 7)) {
|
||||
$target = trim (substr $text, 7);
|
||||
}
|
||||
|
||||
if (! defined $target || ($target eq '')) {
|
||||
$target = $chattername;
|
||||
}
|
||||
|
||||
$reply = 'подаёт шот водки с небольшим маринованным огурчиком на блюдце для ' . $target . '. Из огурчика торчит небольшая вилочка.';
|
||||
$bot->send_long_message ('utf8', 0, "PRIVMSG\001ACTION", $chatid, $reply);
|
||||
return;
|
||||
} elsif (substr ($text, 1, 4) eq 'beer' || substr ($text, 1, 4) eq 'пиво') {
|
||||
my $target;
|
||||
|
||||
if ((length ($text) > 6)) {
|
||||
$target = trim (substr $text, 6);
|
||||
}
|
||||
|
||||
if (! defined $target || ($target eq '')) {
|
||||
$target = $chattername;
|
||||
}
|
||||
|
||||
$reply = 'бахает об стол перед ' . $target . ' кружкой холодного пива, часть пенной шапки сползает по запотевшей стенке кружки.';
|
||||
$bot->send_long_message ('utf8', 0, "PRIVMSG\001ACTION", $chatid, $reply);
|
||||
return;
|
||||
} elsif (substr ($text, 1, 7) eq 'tequila') {
|
||||
my $target;
|
||||
|
||||
if ((length ($text) > 9)) {
|
||||
$target = trim (substr $text, 9);
|
||||
}
|
||||
|
||||
if (! defined $target || ($target eq '')) {
|
||||
$target = $chattername;
|
||||
}
|
||||
|
||||
$reply = 'ставит рядом с ' . $target . ' шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли.';
|
||||
$bot->send_long_message ('utf8', 0, "PRIVMSG\001ACTION", $chatid, $reply);
|
||||
return;
|
||||
} elsif (substr ($text, 1, 6) eq 'текила') {
|
||||
my $target;
|
||||
|
||||
if ((length ($text) > 8)) {
|
||||
$target = trim (substr $text, 8);
|
||||
}
|
||||
|
||||
if (! defined $target || ($target eq '')) {
|
||||
$target = $chattername;
|
||||
}
|
||||
|
||||
$reply = 'ставит рядом с ' . $target . ' шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли.';
|
||||
$bot->send_long_message ('utf8', 0, "PRIVMSG\001ACTION", $chatid, $reply);
|
||||
return;
|
||||
} elsif (substr ($text, 1, 6) eq 'whisky') {
|
||||
my $target;
|
||||
|
||||
if ((length ($text) > 8)) {
|
||||
$target = trim (substr $text, 8);
|
||||
}
|
||||
|
||||
if (! defined $target || ($target eq '')) {
|
||||
$target = $chattername;
|
||||
}
|
||||
|
||||
$reply = 'демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около ' . $target . '.';
|
||||
$bot->send_long_message ('utf8', 0, "PRIVMSG\001ACTION", $chatid, $reply);
|
||||
return;
|
||||
} elsif (substr ($text, 1, 5) eq 'виски') {
|
||||
my $target;
|
||||
|
||||
if ((length ($text) > 7)) {
|
||||
$target = trim (substr $text, 7);
|
||||
}
|
||||
|
||||
if (! defined $target || ($target eq '')) {
|
||||
$target = $chattername;
|
||||
}
|
||||
|
||||
$reply = 'демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около ' . $target . '.';
|
||||
$bot->send_long_message ('utf8', 0, "PRIVMSG\001ACTION", $chatid, $reply);
|
||||
return;
|
||||
} elsif (substr ($text, 1, 8) eq 'absinthe') {
|
||||
my $target;
|
||||
|
||||
if ((length ($text) > 10)) {
|
||||
$target = trim (substr $text, 10);
|
||||
}
|
||||
|
||||
if (! defined $target || ($target eq '')) {
|
||||
$target = $chattername;
|
||||
}
|
||||
|
||||
$reply = 'наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, ' . $c->{nick} . ' размешивает оплавившийся кубик в абсенте и подносит стопку ' . $target . '.';
|
||||
$bot->send_long_message ('utf8', 0, "PRIVMSG\001ACTION", $chatid, $reply);
|
||||
return;
|
||||
} elsif (substr ($text, 1, 6) eq 'абсент') {
|
||||
my $target;
|
||||
|
||||
if ((length ($text) > 8)) {
|
||||
$target = trim (substr $text, 8);
|
||||
}
|
||||
|
||||
if (! defined $target || ($target eq '')) {
|
||||
$target = $chattername;
|
||||
}
|
||||
|
||||
$reply = 'наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, ' . $c->{nick} . ' размешивает оплавившийся кубик в абсенте и подносит стопку ' . $target . '.';
|
||||
$bot->send_long_message ('utf8', 0, "PRIVMSG\001ACTION", $chatid, $reply);
|
||||
return;
|
||||
} elsif (substr ($text, 1, 2) eq 'w ' || substr ($text, 1, 2) eq 'п ') {
|
||||
my $city = substr $text, 2;
|
||||
$reply = Weather ($city) =~ tr/\n/ /r;
|
||||
} elsif (substr ($text, 1) eq 'anek' || substr ($text, 1) eq 'анек' || substr ($text, 1) eq 'анекдот' ) {
|
||||
$reply = Anek ();
|
||||
} elsif (substr ($text, 1) eq 'coin' || substr ($text, 1) eq 'монетка') {
|
||||
if (rand (101) < 0.016) {
|
||||
$reply = 'ребро';
|
||||
} else {
|
||||
if (irand (2) == 0) {
|
||||
if (irand (2) == 0) {
|
||||
$reply = 'орёл';
|
||||
} else {
|
||||
$reply = 'аверс';
|
||||
}
|
||||
} else {
|
||||
if (irand (2) == 0) {
|
||||
$reply = 'решка';
|
||||
} else {
|
||||
$reply = 'реверс';
|
||||
}
|
||||
}
|
||||
}
|
||||
} elsif (substr ($text, 1) eq 'roll' || substr ($text, 1) eq 'dice' || substr ($text, 1) eq 'кости') {
|
||||
$reply = sprintf 'На первой кости выпало %d, а на второй — %d.', irand (6) + 1, irand (6) + 1;
|
||||
} elsif (substr ($text, 1) eq 'version' || substr ($text, 1) eq 'ver') {
|
||||
$reply = 'Версия нуль.чего-то_там.чего-то_там';
|
||||
} elsif (substr ($text, 1) eq 'lat' || substr ($text, 1) eq 'лат') {
|
||||
$reply = Lat ();
|
||||
} elsif (substr ($text, 1) eq 'cat' || substr ($text, 1) eq 'кис') {
|
||||
$reply = Kitty ();
|
||||
} elsif (substr ($text, 1) eq 'fox' || substr ($text, 1) eq 'лис') {
|
||||
$reply = Fox ();
|
||||
} elsif (substr ($text, 1) eq 'frog' || substr ($text, 1) eq 'лягушка') {
|
||||
$reply = Frog ();
|
||||
} elsif (substr ($text, 1) eq 'horse' || substr ($text, 1) eq 'лошадь' || substr ($text, 1) eq 'лошадка') {
|
||||
$reply = Horse ();
|
||||
} elsif (substr ($text, 1) eq 'snail' || substr ($text, 1) eq 'улитка') {
|
||||
$reply = Snail ();
|
||||
} elsif (substr ($text, 1) eq 'dig' || substr ($text, 1) eq 'копать') {
|
||||
$reply = Dig ($chattername);
|
||||
} elsif (substr ($text, 1) eq 'fish' || substr ($text, 1) eq 'fisher' || substr ($text, 1) eq 'рыба' || substr ($text, 1) eq 'рыбка' || substr ($text, 1) eq 'рыбалка') {
|
||||
$reply = Fish ($chattername);
|
||||
} elsif (substr ($text, 1) eq 'buni') {
|
||||
$reply = Buni ();
|
||||
} elsif (substr ($text, 1) eq 'xkcd') {
|
||||
$reply = Xkcd ();
|
||||
} elsif (substr ($text, 1) eq 'monkeyuser') {
|
||||
$reply = Monkeyuser ();
|
||||
} elsif (substr ($text, 1) eq 'drink' || substr ($text, 1) eq 'праздник') {
|
||||
$reply = Drink ();
|
||||
} elsif (substr ($text, 1) eq 'bunny' || substr ($text, 1) eq 'rabbit' || substr ($text, 1) eq 'кролик') {
|
||||
$reply = Rabbit ();
|
||||
} elsif (substr ($text, 1) eq 'owl' || substr ($text, 1) eq 'сова') {
|
||||
$reply = Owl ();
|
||||
} elsif ((length ($text) >= 6 && (substr ($text, 1, 6) eq 'karma ' || substr ($text, 1, 6) eq 'карма ')) || substr ($text, 1) eq 'karma' || substr ($text, 1) eq 'карма') {
|
||||
my $mytext = '';
|
||||
|
||||
if (length ($text) > 6) {
|
||||
$mytext = substr $text, 7;
|
||||
chomp $mytext;
|
||||
$mytext = trim $mytext;
|
||||
} else {
|
||||
$mytext = '';
|
||||
}
|
||||
|
||||
$reply = KarmaGet ($chatid, $mytext);
|
||||
} elsif (substr ($text, 1) eq 'friday' || substr ($text, 1) eq 'пятница') {
|
||||
$reply = Friday ();
|
||||
} elsif (substr ($text, 1) eq 'proverb' || substr ($text, 1) eq 'пословица') {
|
||||
$reply = Proverb ();
|
||||
} elsif (substr ($text, 1) eq 'fortune' || substr ($text, 1) eq 'фортунка' || substr ($text, 1) eq 'f' || substr ($text, 1) eq 'ф') {
|
||||
my $phrase = Fortune ();
|
||||
$reply = $phrase;
|
||||
} elsif (substr ($text, 1) eq 'ping') {
|
||||
$reply = 'Pong.';
|
||||
} elsif (substr ($text, 1) eq 'пинг') {
|
||||
$reply = 'Понг.';
|
||||
} elsif (substr ($text, 1) eq 'kde' || substr ($text, 1) eq 'кде') {
|
||||
my @phrases = (
|
||||
'Нет, я не буду поднимать вам плазму.',
|
||||
'Повторяйте эту мантру по утрам не менее 5 раз: "Плазма не падает." И, возможно, она перестанет у вас падать.'
|
||||
);
|
||||
|
||||
$reply = $phrases[irand ($#phrases + 1)];
|
||||
} elsif (substr ($text, 1) eq '=(' || substr ($text, 1) eq ':(' || substr ($text, 1) eq '):') {
|
||||
$reply = ':)';
|
||||
} elsif (substr ($text, 1) eq '=)' || substr ($text, 1) eq ':)' || substr ($text, 1) eq '(:') {
|
||||
$reply = ':D';
|
||||
}
|
||||
|
||||
$log->warn (Dumper ($m));
|
||||
return;
|
||||
};
|
||||
|
||||
my $on_ctcp_source = sub {
|
||||
my $self = shift;
|
||||
my $msg = shift;
|
||||
my $response_to = (split /!/, $msg->{prefix}, 2)[0];
|
||||
$self->write (NOTICE => $response_to => $self->ctcp (SOURCE => 'https://github.com/aleesa-bot/aleesa-irc'));
|
||||
return;
|
||||
};
|
||||
|
||||
my $on_ctcp_finger = sub {
|
||||
my $self = shift;
|
||||
my $msg = shift;
|
||||
my $response_to = (split /!/, $msg->{prefix}, 2)[0];
|
||||
$self->write (NOTICE => $response_to => $self->ctcp (FINGER => $c->{nick}));
|
||||
return;
|
||||
};
|
||||
|
||||
my $on_ctcp_ping = sub {
|
||||
my $self = shift;
|
||||
my $msg = shift;
|
||||
my $response_to = (split /!/, $msg->{prefix}, 2)[0];
|
||||
$self->write (NOTICE => $response_to => $self->ctcp (PING => $msg->{params}->[1]));
|
||||
return;
|
||||
};
|
||||
|
||||
my $on_ctcp_time = sub {
|
||||
my $self = shift;
|
||||
my $msg = shift;
|
||||
my $response_to = (split /!/, $msg->{prefix}, 2)[0];
|
||||
$self->write (NOTICE => $response_to => $self->ctcp (TIME => gmtime_to_iso8601_datetime (time ())));
|
||||
return;
|
||||
};
|
||||
|
||||
my $on_ctcp_clientinfo = sub {
|
||||
my $self = shift;
|
||||
my $msg = shift;
|
||||
my $response_to = (split /!/, $msg->{prefix}, 2)[0];
|
||||
$self->write (NOTICE => $response_to => $self->ctcp (CLIENTINFO => 'ACTION CLIENTINFO FINGER PING SOURCE TIME USERINFO VERSION'));
|
||||
return;
|
||||
};
|
||||
|
||||
my $on_irc_end_of_motd = sub {
|
||||
my $self = shift;
|
||||
|
||||
# Идентифицируемся в NickServ, если надо
|
||||
if (defined ($c->{identify}) && $c->{identify} ne '') {
|
||||
# TODO: invent heuristics to detect different login|identify commands depending on particular irc net or
|
||||
# known ircd detected during login procedure
|
||||
# Эта команда используется на фриноде (мир праху её) и libera.chat
|
||||
$self->write ( qw (PRIVMSG NickServ IDENTIFY $c->{nick} $c->{identify}), \&_on_nickserv_identify);
|
||||
|
||||
until ($identified) { ## no critic (ControlStructures::ProhibitUntilBlocks)
|
||||
sleep 1;
|
||||
}
|
||||
}
|
||||
|
||||
# А теперь заходим на все интересующие нас каналы
|
||||
foreach my $chan (@{$c->{channels}}) {
|
||||
$self->write ( ('JOIN', $chan), \&_on_join_channel);
|
||||
}
|
||||
return;
|
||||
};
|
||||
|
||||
sub _on_nickserv_identify {
|
||||
my $self = shift;
|
||||
my $error = shift;
|
||||
|
||||
if ($error) {
|
||||
$log->error ("NickServ identify failed: $error");
|
||||
exit 1;
|
||||
} else {
|
||||
$log->info ('Identified with Nickserv');
|
||||
$identified = 1;
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub _on_join_channel {
|
||||
my $self = shift;
|
||||
my $error = shift;
|
||||
|
||||
if ($error) {
|
||||
$log->error ("Unable to join: $error");
|
||||
} else {
|
||||
$log->info ('Joined');
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
# зовётся в момент "после коннекта"
|
||||
sub _on_connect {
|
||||
my $self = shift;
|
||||
my $error = shift;
|
||||
|
||||
if ($error) {
|
||||
$log->error ("Unable to connect: $error");
|
||||
exit 1;
|
||||
} else {
|
||||
$log->info ('Connected.');
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub _on_disconnect {
|
||||
my $self = shift;
|
||||
my $error = shift;
|
||||
|
||||
if ($error) {
|
||||
$log->error ("Unable to Disconnect: $error");
|
||||
} else {
|
||||
$log->info ('Disconnected.');
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
# main loop, он же event loop
|
||||
sub RunIRCApp {
|
||||
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 { return $parse_redis_message->(@_); }
|
||||
);
|
||||
}
|
||||
}
|
||||
);
|
||||
|
||||
my $irc = Mojo::IRC->new (
|
||||
nick => $c->{nick},
|
||||
user => $c->{nick},
|
||||
server => sprintf '%s:%s', $c->{server}, $c->{port},
|
||||
);
|
||||
|
||||
# Нахуй эту вашу проверку подлинности, нам работать надо, а не шашечки.
|
||||
if ($c->{ssl}) {
|
||||
$irc->tls({ 'insecure' => 1 });
|
||||
}
|
||||
|
||||
# включим обработку ctcp-событий
|
||||
$irc->parser(Parse::IRC->new(ctcp => 1));
|
||||
|
||||
# добавим коллбэк на момент "после подключения"
|
||||
$irc->connect(\&_on_connect);
|
||||
|
||||
# когда приходит это событие, сервер нас поприветствовал и мы можем уже пробовать идентифицироваться у nickserv
|
||||
# (если надо) и джойниться к каналам.
|
||||
$irc->on ( irc_rpl_endofmotd => sub { return $on_irc_end_of_motd->(@_); } );
|
||||
|
||||
# этот коллбэк будет зваться по мере бесед, сюда попадают все фразы и ctcp
|
||||
$irc->on ( irc_privmsg => sub { return $on_irc_privmsg->(@_); } );
|
||||
|
||||
# эти коллбэки будет зваться когда приходят ctcp запросы.
|
||||
$irc->on ( ctcp_source => sub { return $on_ctcp_source->(@_); } );
|
||||
$irc->on ( ctcp_finger => sub { return $on_ctcp_finger->(@_); } );
|
||||
$irc->on ( ctcp_userinfo => sub { return $on_ctcp_finger->(@_); } );
|
||||
$irc->on ( ctcp_ping => sub { return $on_ctcp_ping->(@_); } );
|
||||
$irc->on ( ctcp_time => sub { return $on_ctcp_time->(@_); } );
|
||||
$irc->on ( ctcp_clientinfo => sub { return $on_ctcp_clientinfo->(@_); } );
|
||||
|
||||
# зарегистрируем дефолтные коллбэки на всё, что не закастомизировано
|
||||
$irc->register_default_event_handlers;
|
||||
|
||||
do { Mojo::IOLoop->start } until Mojo::IOLoop->is_running;
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
Reference in New Issue
Block a user