Initial commit

2022-01-02 16:24:49 +03:00
commit 40b9bb03c3
23 changed files with 4832 additions and 0 deletions
--- a/lib/Conf.pm
+++ b/lib/Conf.pm
@@ -0,0 +1,37 @@
+package Conf;
+# Загружает конфиг
+
+use 5.018;
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use Encode qw (encode decode);
+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 $json;
+	my $len = (stat $c) [7];
+	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";
+	}
+
+	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:
--- a/lib/Fortune.pm
+++ b/lib/Fortune.pm
@@ -0,0 +1,87 @@
+package Fortune;
+# Прокатят любые источники из fortune_mod. Текстовой файл с разделителем "\n%\n" мнжду фразами.
+
+use 5.018;
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use Carp qw (cluck croak);
+use File::Path qw (make_path);
+use Log::Any qw ($log);
+use Math::Random::Secure qw (irand);
+use SQLite_File;
+
+use Conf qw (LoadConf);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (Seed Fortune);
+
+my $c = LoadConf ();
+my $dir = $c->{fortune}->{dir};
+my $srcdir = $c->{fortune}->{srcdir};
+
+sub Seed () {
+	unless (-d $dir) {
+		make_path ($dir)  ||  croak "Unable to create $dir: $OS_ERROR";
+	}
+
+	my $backingfile = sprintf '%s/fortune.sqlite', $dir;
+
+	if (-f $backingfile) {
+		unlink $backingfile   ||  croak "Unable to remove $backingfile: $OS_ERROR";
+	}
+
+	tie my @fortune, 'SQLite_File', $backingfile  ||  croak "Unable to tie to $backingfile: $OS_ERROR";
+
+	opendir (my $srcdirhandle, $srcdir)  ||  croak "Unable to open $srcdir: $OS_ERROR";
+
+	while (my $fortunefile = readdir $srcdirhandle) {
+		my $srcfile = sprintf '%s/%s', $srcdir, $fortunefile;
+
+		unless (-f $srcfile) {
+			next;
+		}
+
+		if ($fortunefile =~ m/^\.+$/) { ## no critic (RegularExpressions::RequireDotMatchAnything)
+			next;
+		}
+
+		open (my $fh, '<', $srcfile)  ||  croak "Unable to open $srcfile, $OS_ERROR";
+		# set correct phrase delimiter
+		local $INPUT_RECORD_SEPARATOR = "\n%\n";
+
+		while (readline $fh) {
+			my $phrase = substr $_, 0, -3;
+			push @fortune, $phrase;
+		}
+
+		close $fh;  ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
+	}
+
+	closedir $srcdirhandle;
+	untie @fortune;
+	return;
+}
+
+# Просто вернём ответ
+sub Fortune () {
+	my $backingfile = sprintf '%s/fortune.sqlite', $dir;
+
+	tie my @array, 'SQLite_File', $backingfile  ||  do {
+		$log->error ("[ERROR] Unable to tie to $backingfile: $OS_ERROR");
+		return '';
+	};
+
+	my $phrase = $array[irand ($#array + 1)];
+	# decode?
+	utf8::decode $phrase;
+	untie @array;
+	return $phrase;
+}
+
+1;
+
+# vim: ft=perl noet ai ts=4 sw=4 sts=4:
--- a/lib/Friday.pm
+++ b/lib/Friday.pm
@@ -0,0 +1,97 @@
+package Friday;
+# Данные модуля спёрты с https://raw.githubusercontent.com/isida/vi/master/data/friday.txt
+
+use 5.018;
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use Carp qw (cluck croak);
+use File::Path qw (make_path);
+use Log::Any qw ($log);
+use Math::Random::Secure qw (irand);
+use SQLite_File;
+
+use Conf qw (LoadConf);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (Seed Friday);
+
+my $c = LoadConf ();
+my $dir = $c->{friday}->{dir};
+my $srcfile = $c->{friday}->{src};
+my @dow = qw (monday tuesday wednesday thursday friday saturday sunday);
+
+sub Seed () {
+	unless (-d $dir) {
+		make_path ($dir)  ||  croak "Unable to create $dir: $OS_ERROR";
+	}
+
+	my $friday;
+
+	for (0..$#dow) {
+		my $backingfile = sprintf '%s/%s.sqlite', $dir, $dow[$_];
+
+		if (-f $backingfile) {
+			unlink $backingfile   ||  croak "Unable to remove $backingfile: $OS_ERROR\n";
+		}
+
+		tie @{$friday->[$_]}, 'SQLite_File', $backingfile  ||  croak "Unable to tie to $backingfile: $OS_ERROR\n";
+	}
+
+	open (my $fh, '<', $srcfile)  ||  croak "Unable to open $srcfile, $OS_ERROR\n";
+
+	while (readline $fh) {
+		unless (m/ \|\| /xmsg) {
+			next;
+		}
+
+		chomp();
+		my ($phrase, $days) = split / \|\| /;  ## no critic (RegularExpressions::RequireDotMatchAnything), do you see ANY dots here?
+		my @daylist = split(//, $days);  ## no critic (RegularExpressions::RequireDotMatchAnything), do you see ANY dots here?
+
+		foreach my $day (@daylist) {
+			unless (defined $day) {
+				next;
+			}
+
+			unless ($day =~ /^\d$/) {  ## no critic (RegularExpressions::RequireDotMatchAnything), do you see ANY dots here?
+				next;
+			}
+
+			if (defined $phrase && ($phrase ne '') && ($phrase !~ m/^\s+$/xmsg)) {
+				push @{$friday->[$day - 1]}, $phrase;
+			}
+		}
+	}
+
+	close $fh;  ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
+
+	for (0..$#dow) {
+		untie $friday->[$_];
+	}
+
+	return;
+}
+
+# just return answer
+sub Friday () {
+	my $today = (localtime time)[6] - 1;
+	my $backingfile = sprintf '%s/%s.sqlite', $dir, $dow[$today];
+
+	tie my @array, 'SQLite_File', $backingfile  ||  do {
+		$log->error ("[ERROR] Unable to tie to $backingfile: $OS_ERROR\n");
+		return '';
+	};
+
+	my $phrase = $array[irand ($#array + 1)];
+	utf8::decode $phrase;
+	untie @array;
+	return $phrase;
+}
+
+1;
+
+# vim: ft=perl noet ai ts=4 sw=4 sts=4:
--- a/lib/Lat.pm
+++ b/lib/Lat.pm
@@ -0,0 +1,75 @@
+package Lat;
+# Крылатые латинские выражения спёрты с https://ru.wikipedia.org/wiki/Список_крылатых_латинских_выражений
+
+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 File::Basename qw (dirname);
+use File::Path qw (make_path);
+use Hailo;
+use Log::Any qw ($log);
+
+use Conf qw (LoadConf);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (Train Lat);
+
+my $c = LoadConf ();
+my $brain = $c->{lat}->{brain};
+my $srcfile = $c->{lat}->{src};
+
+sub Train () {
+	my $braindir = dirname $brain;
+
+	unless (-d $braindir) {
+		make_path ($braindir) or do {
+			cluck "Unable to create $braindir: $OS_ERROR";
+			exit 1;
+		};
+	}
+
+	my $lat = Hailo->new (
+		brain => $brain,
+		# В нашем случае среднее количество слов в фразе равно 3
+		order => 2
+	);
+
+	$lat->train ($srcfile);
+	my ($tokens, $expressions) = ($lat->stats ())[0,1];
+	printf "Total tokens: %s\nTotal expressions: %s\n", $tokens, $expressions;
+	$lat->save ();
+	return;
+}
+
+# Просто вернём ответ
+sub Lat () {
+	my $braindir = dirname $brain;
+
+	unless (-d $braindir) {
+		$log->error ("[ERROR] No lat module data: $braindir is absent! Train lat first.");
+		return '';
+	}
+
+	unless (-f $brain) {
+		$log->error ("[ERROR] No lat module data: $brain is absent! Train lat first.");
+		return '';
+	}
+
+	my $lat = Hailo->new (
+		brain => $brain,
+		# В нашем случае среднее количество слов в фразе равно 3
+		order => 2,
+		save_on_exit => 0
+	);
+
+	return $lat->reply ();
+}
+
+1;
+
+# vim: ft=perl noet ai ts=4 sw=4 sts=4:
--- a/lib/Phrases.pm
+++ b/lib/Phrases.pm
@@ -0,0 +1,161 @@
+package Phrases;
+
+# Общие модули - синтаксис, кодировки итд
+use 5.018;
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+
+# Модули для работы приложения
+use Log::Any qw ($log);
+# Чтобы "уж точно" использовать hiredis-биндинги, загрузим этот модуль перед Mojo::Redis
+use Protocol::Redis::XS;
+use Mojo::Redis;
+use Mojo::IOLoop;
+use Mojo::IOLoop::Signal;
+use Data::Dumper;
+
+use Conf qw (LoadConf);
+use Fortune qw (Fortune);
+use Friday qw (Friday);
+use Lat qw (Lat);
+use Proverb qw (Proverb);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (RunPhrases);
+
+my $c = LoadConf ();
+my $fwd_cnt = $c->{'forward_max'} // 5;
+
+# Основной парсер
+my $parse_message = sub {
+	my $self = shift;
+	my $m = shift;
+	my $answer = $m;
+	my $send_to = $m->{plugin};
+	my $reply;
+
+	if (defined $answer->{misc}) {
+		unless (defined $answer->{misc}->{fwd_cnt}) {
+			$answer->{misc}->{fwd_cnt} = 1;
+		} else {
+			if ($answer->{misc}->{fwd_cnt} > $fwd_cnt) {
+				$log->error ('Forward loop detected, discarding message.');
+				$log->debug (Dumper $m);
+				return;
+			} else {
+				$answer->{misc}->{fwd_cnt}++;
+			}
+		}
+
+		unless (defined $answer->{misc}->{answer}) {
+			$answer->{misc}->{answer} = 1;
+		}
+
+		unless (defined $answer->{misc}->{csign}) {
+			$answer->{misc}->{csign} = '!';
+		}
+	} else {
+		$answer->{misc}->{answer} = 1;
+		$answer->{misc}->{csign} = '!';
+	}
+
+	$log->debug ('[DEBUG] Incoming message ' . Dumper ($m));
+
+	if (substr ($m->{message}, 0, 1) eq $answer->{misc}->{csign}) {
+		if ((substr ($m->{message}, 1) eq 'lat'  ||  substr ($m->{message}, 1) eq 'лат')) {
+			$reply = Lat ();
+		} elsif (substr ($m->{message}, 1) eq 'friday'  ||  substr ($m->{message}, 1) eq 'пятница') {
+			$reply = Friday ();
+		} elsif (substr ($m->{message}, 1) eq 'proverb'  ||  substr ($m->{message}, 1) eq 'пословица') {
+			$reply = Proverb ();
+		} elsif (substr ($m->{message}, 1) eq 'fortune'  ||  substr ($m->{message}, 1) eq 'фортунка'  ||
+		         substr ($m->{message}, 1) eq 'f'  ||  substr ($m->{message}, 1) eq 'ф') {
+			if ($m->{plugin} eq 'telegram') {
+				$reply = sprintf "```\n%s\n```\n", trim (Fortune ());
+			} else {
+				$reply = trim (Fortune ());
+			}
+		}
+	}
+
+	$log->debug ("[DEBUG] Sending message to channel $send_to " . Dumper ($answer));
+
+	if (defined $reply && $answer->{misc}->{answer}) {
+		$answer->{message} = $reply;
+
+		$self->json ($send_to)->notify (
+			$send_to => $answer
+		);
+	}
+
+	return;
+};
+
+my $__signal_handler = sub {
+	my ($self, $name) = @_;
+	$log->info ("[INFO] Caught a signal $name");
+
+	if (defined $main::pidfile && -f $main::pidfile) {
+		unlink $main::pidfile;
+	}
+
+	exit 0;
+};
+
+
+# main loop, он же event loop
+sub RunPhrases {
+	$log->info ("[INFO] Connecting to $c->{server}, $c->{port}");
+
+	my $redis = Mojo::Redis->new (
+		sprintf 'redis://%s:%s/1', $c->{server}, $c->{port}
+	);
+
+	$log->info ('[INFO] Registering connection-event callback');
+
+	$redis->on (
+		connection => sub {
+			my ($r, $connection) = @_;
+
+			$log->info ('[INFO] Triggering callback on new client connection');
+
+			# Залоггируем ошибку, если соединение внезапно порвалось.
+			$connection->on (
+				error => sub {
+					my ($conn, $error) = @_;
+					$log->error ("[ERROR] Redis connection error: $error");
+					return;
+				}
+			);
+
+			return;
+		}
+	);
+
+	my $pubsub = $redis->pubsub;
+	my $sub;
+	$log->info ('[INFO] Subscribing to redis channels');
+
+	foreach my $channel (@{$c->{channels}}) {
+		$log->debug ("[DEBUG] Subscribing to $channel");
+
+		$sub->{$channel} = $pubsub->json ($channel)->listen (
+			$channel => sub { $parse_message->(@_); }
+		);
+	}
+
+	Mojo::IOLoop::Signal->on (
+		TERM => $__signal_handler,
+		INT  => $__signal_handler
+	);
+
+	do { Mojo::IOLoop->start } until Mojo::IOLoop->is_running;
+	return;
+}
+
+1;
+
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
--- a/lib/Proverb.pm
+++ b/lib/Proverb.pm
@@ -0,0 +1,89 @@
+package Proverb;
+# Пословицы и поговорки
+
+use 5.018;
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use Carp qw (cluck croak);
+use File::Path qw (make_path);
+use Log::Any qw ($log);
+use Math::Random::Secure qw (irand);
+use Mojo::Util qw (trim);
+use SQLite_File;
+
+use Conf qw (LoadConf);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (Seed Proverb);
+
+my $c = LoadConf ();
+my $dir = $c->{proverb}->{dir};
+my $srcdir = $c->{proverb}->{srcdir};
+
+sub Seed () {
+	unless (-d $dir) {
+		make_path ($dir)  ||  croak "Unable to create $dir: $OS_ERROR";
+	}
+
+	my $backingfile = sprintf '%s/proverb.sqlite', $dir;
+
+	if (-f $backingfile) {
+		unlink $backingfile   ||  croak "Unable to remove $backingfile: $OS_ERROR";
+	}
+
+	tie my @proverb, 'SQLite_File', $backingfile  ||  croak "Unable to tie to $backingfile: $OS_ERROR";
+	opendir (my $srcdirhandle, $srcdir)  ||  croak "Unable to open $srcdir: $OS_ERROR";
+
+	while (my $proverbfile = readdir $srcdirhandle) {
+		my $srcfile = sprintf '%s/%s', $srcdir, $proverbfile;
+
+		unless (-f $srcfile) {
+			next;
+		}
+
+		if ($proverbfile =~ m/^\.+$/) {  ## no critic (RegularExpressions::RequireDotMatchAnything), do you see ANY dots here?
+			next;
+		}
+
+		open (my $fh, '<', $srcfile)  ||  croak "Unable to open $srcfile, $OS_ERROR";
+
+		while (readline $fh) {
+			chomp;
+			my $str = trim ($_);
+
+			if ($str ne '') {
+				push @proverb, $str;
+			}
+		}
+
+		close $fh;  ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
+	}
+
+	closedir $srcdirhandle;
+	untie @proverb;
+	return;
+}
+
+# Просто вернём ответ
+sub Proverb () {
+	my $backingfile = sprintf '%s/proverb.sqlite', $dir;
+
+	tie my @array, 'SQLite_File', $backingfile  ||  do {
+		$log->error ("[ERROR] Unable to tie to $backingfile: $OS_ERROR");
+		return '';
+	};
+
+	my $phrase = $array[irand ($#array + 1)];
+	# decode?
+	utf8::decode $phrase;
+	untie @array;
+	return $phrase;
+}
+
+1;
+
+# vim: ft=perl noet ai ts=4 sw=4 sts=4: