Last commit

* Добавлено описание поля misc->good_morning в README
* Проверяем входной JSON на наличие всех полей и фиксим дефолтами
* Более аккуратная работа с substr - больше перестраховок
* Правка коментариев

.perlcriticrc

@@ -95,3 +95,21 @@ lib_sections    = NAME | VERSION | DESCRIPTION | AUTHOR | LICENSE AND COPYRIGHT
 
 [-Variables::ProhibitPackageVars]
 # fuck off
+
+[-Editor::RequireEmacsFileVariables]
+
+[-TooMuchCode::ProhibitUnnecessaryUTF8Pragma]
+
+[-CodeLayout::RequireASCII]
+
+[-TooMuchCode::ProhibitDuplicateLiteral]
+
+[-ErrorHandling::RequireUseOfExceptions]
+
+[-ValuesAndExpressions::RequireConstantOnLeftSideOfEquality]
+
+[-Lax::RequireConstantOnLeftSideOfEquality::ExceptEq]
+
+[-Miscellanea::ProhibitUnrestrictedNoCritic]
+
+[-Lax::ProhibitEmptyQuotes::ExceptAsFallback]

README

@@ -5,12 +5,18 @@ aleesa-misc
 Работает по протоколу Redis pubsub.
 
 
+Disclaimer
+-----------------------------------------------------------------------------------------------------------------------
+Вся дальнейшая разработка логики этого модуля будет вестись в рамках проекта aleesa-misc-go. Этот репозиторий остаётся
+исключительно для образовательных целей.
+
+
 Механика работы
 -----------------------------------------------------------------------------------------------------------------------
 Роутер подписан на канал misc.
 
-Модули, реализующие "клиентские протоколы" - telegram, irc, jabber и проч, подписаны на канал своего протокола. Входящие
+Модули, реализующие "клиентские протоколы" - telegram, irc, jabber и проч, подписаны на канал своего протокола.
-сообщения они получают только через этот канал.
+Входящие сообщения они получают только через этот канал.
 
 Модули, реализующие иную функциональность также подписаны каждый на свой канал. Кроме того, для реализации
 дополнительных синхронных возможностей, они могут слушать например http запросы на отдельных - ip:портах. Но это уже
@@ -38,10 +44,13 @@ misc->csign      - command sign - значок, которым предваря
                    такой настройки нету. Изначально настройка задаётся в конфиге чат-модуля (aleesa-telegram,
                    например).
 
-misc->fwd_cnt    - количество пересылок сообщения. Значение по-умолчанию 5. Предполагается, что при пересылке
+misc->fwd_cnt      - количество пересылок сообщения. Значение по-умолчанию 1. Предполагается, что при пересылке
                    сообщения, модуль будет инкрементировать это значение и заодно проверять, что оно не превышает
                    настройку forwards_max в конфиге или 5, если в конфиге такой настройки нету.
 
+misc->good_morning - флажок признака сообщения-фразы дня, которая по идее осылается в ~8 часов по мск. Используется в
+                   модуле phrases.
+
 misc->msg_format   - Использовать форматирование в сообщении. На текущий момент этот флажок выставляется в модуле
                    telegram и благополучно проходит через модуль misc, далее попадает в модуль phrases, и, наконец,
                    возвращается в модуль telegram, чтобы выходное сообщение было отослано как отформатированное.
@@ -65,8 +74,9 @@ development tools - gcc, gcc-g++, perl-devel, make, cmake и так далее.
 Если всё хорошо, то после создания data/config.json из data/config_sample.json и можно запускать приложение. Оно
 запустится как unix daemon.
 
-В каталоге contrib находится скрипт для alpine linux, системы инициализации openrc. Этот скрипт достаточно положить В
+В каталоге contrib находится скрипт для alpine linux, системы инициализации openrc. Этот скрипт достаточно положить в
-/etc/init.d/aleesa-misc сконфигурить сервис по инструкции выше и после этого сервис запускается командой:
+/etc/init.d/aleesa-misc, сконфигурить сервис по инструкции выше и, после этого, сервис запускается командой:
 service aleesa-misc start
-в автозагрузку его можно прописать через команду
+
+В автозагрузку его можно прописать через команду:
 rc-update add aleesa-misc default

TODO

@@ -1,28 +0,0 @@
-Реализовать парсер для команды !admin :
-* Вероятно, попротокольно, так как эта команда есть только в telegram, но формально должна появиться в jabber и irc.
-* Понадобится отдельный способ запросить "протокольный" плагин на тему админ ли чел, который хочет использовать
-  команду !admin.
-* Для телеги у нас есть возможность автоматически определять админов.
-* Для IRC - есть возможность определить op-ов. (+ к тому нужно следить за сменой статуса - парсить соответствующие
-  ивенты).
-* Для jabber - пока непонятно.
-
-Брать каналы из конфига. Те самые redis-каналы, в которые надо отсылать сообщения. Продумать вопрос с оптимальным форматом конфига.
-  Пока что он видится в фомате хэша
-  {
-    channels : {
-      telegram : telegram,
-      craniac : craniac,
-      irc : irc,
-      webapp : webapp,
-      ...
-    }
-  }
-но не на всех этих каналах надо слушать, в какие-то достаточно только писать.
-
-Реализовать возможность релоада конфига. Но для начала понять, нужно ли оно нам?
-
-Решить вопрос с Cron-ом. Будет ли это отдельный демонок либо эти функции будут в роутере (чего наверно не хотелось бы).
-В Cron у нас войдёт как минимум утренняя фортунка и скорее всего rss, когда появится.
-
-Проверить момент, когда при старте сервиса redis ещё не запущен.

bin/aleesa-misc

@@ -1,6 +1,6 @@
 #!/usr/bin/perl
 
-use 5.018;
+use 5.018; ## no critic (ProhibitImplicitImport)
 use strict;
 use warnings;
 use utf8;
@@ -29,9 +29,10 @@ no Cwd;
 use Cwd::utf8 qw (chdir abs_path);
 use File::Basename qw (basename dirname);
 use File::Path qw (make_path);
+use File::Spec ();
 use Log::Any qw ($log);
-use Log::Any::Adapter;
+use Log::Any::Adapter ();
-use Log::Any::For::Std;
+use Log::Any::For::Std ();
 use POSIX qw (setgid setuid setsid);
 use Conf qw (LoadConf);
 use Misc qw (RunMisc);
@@ -69,8 +70,8 @@ if ($UID == 0) {
 		make_path (
 			$piddir, {
 				uid   => $uid,
-				group => $gid
+				group => $gid,
-			}
+			},
 		);
 	}
 
@@ -81,8 +82,8 @@ if ($UID == 0) {
 			make_path (
 					$logdir, {
 							uid   => $uid,
-							group => $gid
+							group => $gid,
-					}
+					},
 			) or die "Unable to create $logdir: $OS_ERROR\n";
 		}
 	}
@@ -97,7 +98,7 @@ if ($UID == 0) {
 if (defined $logfile) {
 	Log::Any::Adapter->set ('File', $logfile, log_level => $loglevel);
 } else {
-	Log::Any::Adapter->set ('File', '/dev/null');
+	Log::Any::Adapter->set ('File', File::Spec->devnull);
 }
 
 # По-умолчанию, демонизируемся, если явно не указано, что этого делать не надо
@@ -113,7 +114,7 @@ my $apath = abs_path $PROGRAM_NAME;
 unless (defined $apath) {
 	$log->fatal ("[FATAL] Unable to get abs_path: $OS_ERROR\n");
 	exit 1;
-};
+}
 
 our $pidfile = sprintf '%s/%s.pid', $piddir, basename $apath;
 $log->info ("[INFO] Creating pidfile at $pidfile");
@@ -141,7 +142,7 @@ $PROGRAM_NAME = abs_path $PROGRAM_NAME;              ## no critic (Variables::Re
 # И запустим уже наш сервис
 RunMisc ();
 
-if (-f $pidfile) {
+if (-e $pidfile) {
 	unlink $pidfile;
 }
 
@@ -149,8 +150,8 @@ exit 0;
 
 sub daemonize {
 	__fork ();
-	POSIX::setsid ();
+	setsid ();
-	open STDIN, '<', '/dev/null';                    ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
+	open STDIN, '<', File::Spec->devnull;                    ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
 	__fork ();
 	umask 0;
 	return;
@@ -174,7 +175,7 @@ sub __fork {
 sub __signal_handler {
 	$log->info ("[INFO] Caught a signal $OS_ERROR");
 
-	if (-f $pidfile) {
+	if (-e $pidfile) {
 		unlink $pidfile;
 	}
 

cpanfile

@@ -1,14 +1,17 @@
+## no critic
 requires 'Carp',                 '==1.50';
 requires 'Clone',                '==0.45';
 requires 'Cwd',                  '==3.75';
 requires 'Cwd::utf8',            '==0.011';
 requires 'Data::Dumper',         '==2.183';
 requires 'Encode',               '==3.16';
-requires 'English',              '==1.11';
+# Part of perl
+requires 'English',              '0';
 requires 'EV',                   '==4.33';
 requires 'Exporter',             '==5.74';
-requires 'File::Basename',       '0';
+requires 'File::Basename',       '==2.85';
 requires 'File::Path',           '==2.18';
+requires 'File::Spec',           '==3.75';
 requires 'IO::Socket::SSL',      '==2.072';
 requires 'JSON',                 '==4.03';
 requires 'JSON::XS',             '==4.03';
@@ -17,11 +20,11 @@ requires 'Log::Any',             '==1.710';
 requires 'Log::Any::Adapter',    '==1.710';
 requires 'Log::Any::For::Std',   '==0.05';
 requires 'Math::Random::Secure', '==0.080001';
-requires 'Mojolicious',          '==9.22';
+requires 'Mojolicious',          '==9.24';
 requires 'Mojo::Redis',          '==3.27';
 requires 'Mojo::IOLoop::Signal', '==0.003';
+# Part of perl
 requires 'open',                 '0';
 requires 'POSIX',                '0';
-requires 'Protocol::Redis::XS',  '0';
 requires 'utf8',                 '0';
-requires 'version',              '0';
+requires 'version',              '==0.9929';

lib/Conf.pm

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

lib/Misc.pm

@@ -1,22 +1,19 @@
 package Misc;
 
 # Общие модули - синтаксис, кодировки итд
-use 5.018;
+use 5.018; ## no critic (ProhibitImplicitImport)
 use strict;
 use warnings;
 use utf8;
 use open qw (:std :utf8);
 
-use Clone  qw (clone);
 # Модули для работы приложения
+use Clone qw (clone);
+use Data::Dumper qw (Dumper);
 use Log::Any qw ($log);
-use Math::Random::Secure qw (irand);
+use Mojo::Redis ();
-# Чтобы "уж точно" использовать hiredis-биндинги, загрузим этот модуль перед Mojo::Redis
+use Mojo::IOLoop ();
-use Protocol::Redis::XS;
+use Mojo::IOLoop::Signal ();
-use Mojo::Redis;
-use Mojo::IOLoop;
-use Mojo::IOLoop::Signal;
-use Data::Dumper;
 
 use Conf qw (LoadConf);
 
@@ -25,7 +22,11 @@ use Exporter qw (import);
 our @EXPORT_OK = qw (RunMisc);
 
 my $c = LoadConf ();
-my $fwd_cnt = $c->{'forward_max'} // 5;
+my $fwd_cnt = 5;
+
+if (defined $c->{'forward_max'}) {
+	$fwd_cnt = $c->{'forward_max'};
+}
 
 # Основной парсер
 my $parse_message = sub {
@@ -51,13 +52,33 @@ my $parse_message = sub {
 			$answer->{misc}->{answer} = 1;
 		}
 
+		unless (defined $answer->{misc}->{bot_nick}) {
+			$answer->{misc}->{bot_nick} = '';
+		}
+
 		unless (defined $answer->{misc}->{csign}) {
-			$answer->{misc}->{csign} = '!';
+			$answer->{misc}->{csign} = $c->{csign};
+		}
+
+		unless (defined $answer->{misc}->{good_morning}) {
+			$answer->{misc}->{good_morning} = 0;
+		}
+
+		unless (defined $answer->{misc}->{msg_format}) {
+			$answer->{misc}->{msg_format} = 0;
+		}
+
+		unless (defined $answer->{misc}->{username}) {
+			$answer->{misc}->{username} = '';
 		}
 	} else {
 		$answer->{misc}->{answer} = 1;
-		$answer->{misc}->{csign} = '!';
+		$answer->{misc}->{bot_nick} = '';
+		$answer->{misc}->{csign} = $c->{csign};
+		$answer->{misc}->{fwd_cnt} = 1;
+		$answer->{misc}->{good_morning} = 0;
 		$answer->{misc}->{msg_format} = 0;
+		$answer->{misc}->{username} = '';
 	}
 
 	# Если сообщение не попало ни под один шаблон, оно отправляется к craniac-у
@@ -65,9 +86,11 @@ my $parse_message = sub {
 
 	$log->debug ('[DEBUG] Incoming message ' . Dumper ($m));
 
+	my $csign = $answer->{misc}->{csign};
+
 	# Пробуем найти команды. Сообщения, начинающиеся с $answer->{misc}->{csign}
-	if (substr ($m->{message}, 0, 1) eq $answer->{misc}->{csign}) {
+	if ((length $m->{message} > length $csign)  &&  (substr ($m->{message}, 0, length $csign) eq $csign)) {
-		my $cmd = substr $m->{message}, 1;
+		my $cmd = substr $m->{message}, length $csign;
 		my $done = 0;
 
 		# Вначале поищем команды модуля Phrases
@@ -109,26 +132,37 @@ my $parse_message = sub {
 			}
 		}
 
-		# И наконец остальные, более сложные команды, с аргументами
+		# И, наконец, остальные, более сложные команды, с аргументами
 		unless ($done) {
-			if (substr ($m->{message}, 1, 2) eq 'w ' || substr ($m->{message}, 1, 2) eq 'п ') {
+			my @cmds = ('w ', 'п ', 'weather ', 'погодка ', 'погадка ', 'погода ');
-				$send_to = 'webapp';
+
-				$done = 1;
+			while (my $check = pop @cmds) {
-			} elsif (substr ($m->{message}, 1, 8) eq 'weather ' || substr ($m->{message}, 1, 8) eq 'погодка ') {
+				if ((length $cmd > length $check)  &&  substr ($cmd, 0, length $check) eq $check) {
-				$send_to = 'webapp';
-				$done = 1;
-			} elsif (substr ($m->{message}, 1, 7) eq 'погода ' || substr ($m->{message}, 1, 8) eq 'погадка ') {
 					$send_to = 'webapp';
 					$done = 1;
+					last;
 				}
 			}
 
+			$#cmds = -1;
+			@cmds = ('karma ', 'карма ');
+
+			while (my $check = pop @cmds) {
+				if ((length $cmd > length $check)  &&  substr ($cmd, 0, length $check) eq $check) {
+					$send_to = 'phrases';
+					$done = 1;
+					last;
+				}
+			}
+		}
 	# Попробуем найти изменение кармы
-	} elsif (substr ($m->{message}, -2) eq '++'  ||  substr ($m->{message}, -2) eq '--') {
+	} elsif (substr ($m->{message}, 0 - length ('++')) eq '++'  ||  substr ($m->{message}, 0 - length ('--')) eq '--') {
 		my @arr = split /\n/, $m->{message};
 
 		# Предполагается, что фраза - это только одна строка
 		if ($#arr < 1) {
+			# Подпираем это дело - независимо от того, что пришло нам от chat-плагина
+			$answer->{misc}->{answer} = 1;
 			$send_to = 'phrases';
 		}
 	}
@@ -136,7 +170,7 @@ my $parse_message = sub {
 	$log->debug ("[DEBUG] Sending message to channel $send_to " . Dumper ($answer));
 
 	$self->json ($send_to)->notify (
-		$send_to => $answer
+		$send_to => $answer,
 	);
 
 	return;
@@ -146,7 +180,7 @@ my $__signal_handler = sub {
 	my ($self, $name) = @_;
 	$log->info ("[INFO] Caught a signal $name");
 
-	if (defined $main::pidfile && -f $main::pidfile) {
+	if (defined $main::pidfile && -e $main::pidfile) {
 		unlink $main::pidfile;
 	}
 
@@ -154,12 +188,12 @@ my $__signal_handler = sub {
 };
 
 
-# main loop, он же event loop
+# Main loop, он же event loop
 sub RunMisc {
 	$log->info ("[INFO] Connecting to $c->{server}, $c->{port}");
 
 	my $redis = Mojo::Redis->new (
-		sprintf 'redis://%s:%s/1', $c->{server}, $c->{port}
+		sprintf 'redis://%s:%s/1', $c->{server}, $c->{port},
 	);
 
 	$log->info ('[INFO] Registering connection-event callback');
@@ -176,11 +210,11 @@ sub RunMisc {
 					my ($conn, $error) = @_;
 					$log->error ("[ERROR] Redis connection error: $error");
 					return;
-				}
+				},
 			);
 
 			return;
-		}
+		},
 	);
 
 	my $pubsub = $redis->pubsub;
@@ -191,14 +225,12 @@ sub RunMisc {
 		$log->debug ("[DEBUG] Subscribing to $channel");
 
 		$sub->{$channel} = $pubsub->json ($channel)->listen (
-			$channel => sub { $parse_message->(@_); }
+			$channel => sub { $parse_message->(@_); },
 		);
 	}
 
-	Mojo::IOLoop::Signal->on (
+	Mojo::IOLoop::Signal->on (TERM => $__signal_handler);
-		TERM => $__signal_handler,
+	Mojo::IOLoop::Signal->on (INT  => $__signal_handler);
-		INT  => $__signal_handler
-	);
 
 	do { Mojo::IOLoop->start } until Mojo::IOLoop->is_running;
 	return;