aleesa-bot/aleesa-telegram
0
Fork 0
Code Pull Requests Projects Releases Activity

Refactor code

Browse Source 
* move plugins out of botlib.pm
* use make_path instead of mkpath
* squash some bugs
* update .gitignore
* use more correct randomizer, rather than perl own rand()
* coding style fixes
This commit is contained in:
eleksir
2021-01-05 13:42:41 +03:00
parent 8a521d3f3b
commit a1d238949f
20 changed files with 582 additions and 406 deletions
Download Patch File Download Diff File Expand all files Collapse all files

17
.gitignore vendored
View File

@@ -1,7 +1,12 @@
vendor_perl
data/config.json
data/cache
data/telegrambot-brains
data/lat
.idea/**
.vscode/**
aleesa-telegram-bot.pid
TODO
data/cache/**
data/config.json
data/fortune/**
data/friday/**
data/karma/**
data/telegrambot-brains/**
data/lat/**
vendor_perl
_Deparsed_XSubs.pm

8
README.md
View File

@@ -6,9 +6,9 @@ It is based on Perl modules [Telegram::Bot][1] and [Hailo][2] as conversation
generator.
I have to fork [Telegram::Bot][1] and add some of new methods that are already
appear in [Telegram API][3], but author seems to abandon lib. Also i decide to
rename it to avoid collision in future, now it is Teapot::Bot and is bundled
with bot. When lib become mature enough, maybe i release it separately.
appear in [Telegram API][3], but author seems to abandon lib. Also, I decide to
rename it to avoid collision in the future, now it is Teapot::Bot and is bundled
with bot. When lib become mature enough, maybe I release it separately.
Bot config located in **data/config.json**, sample config provided as
**data/sample_config.json**.
@@ -24,7 +24,7 @@ You'll need "Development Tools" or similar group of packages, perl, perl-devel,
perl-local-lib, perl-app-cpanm, sqlite-devel, zlib-devel, openssl-devel,
libdb4-devel (Berkeley DB devel), make.
After installng required dependencies it is possible to run:
After installing required dependencies it is possible to run:
```bash
bash bootstrap.sh

55
bin/aleesa-telegram-bot
View File

@@ -4,32 +4,36 @@ use 5.018;
use strict;
use warnings;
use utf8;
use open qw(:std :utf8);
use English qw( -no_match_vars );
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use version; our $VERSION = qw(1.0);
use version; our $VERSION = qw (1.0);
my $workdir;
# before we run, change working dir
BEGIN {
use Cwd qw(chdir abs_path);
use Cwd qw (chdir abs_path);
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
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 POSIX qw(setgid setuid setsid);
use File::Path qw(make_path);
use File::Basename qw(basename dirname);
use Cwd::utf8 qw (chdir abs_path);
use File::Basename qw (basename dirname);
use File::Path qw (make_path);
use Log::Any::Adapter;
use Log::Any::For::Std;
use conf qw(loadConf);
use telegrambot qw(run_telegrambot);
use POSIX qw (setgid setuid setsid);
use conf qw (loadConf);
use telegrambot qw (run_telegrambot);
sub daemonize;
sub __fork;
@@ -41,8 +45,12 @@ my $runAsUid = $UID;
my $piddir = '/var/run/' . basename (abs_path ($PROGRAM_NAME));
my $C = loadConf ();
my $logfile;
if (defined $C->{'log'}) { $logfile = $C->{'log'}; }
elsif (defined $C->{'debug_log'}) {$logfile = $C->{'debug_log'}; }
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) {
@@ -72,10 +80,8 @@ if ($UID == 0) {
uid => $uid,
group => $gid
}
);
) or die "Unable to create $logdir: $OS_ERROR\n";
}
die "Unable to create $logdir" unless (-d $logdir); ## no critic (ErrorHandling::RequireCarping)
}
# drop privs
@@ -137,14 +143,25 @@ sub daemonize {
sub __fork {
my $pid = fork;
unless (defined $pid) { die "[FATAL] Can't fork: $OS_ERROR\n"; }
exit if ($pid != 0);
unless (defined $pid) {
die "[FATAL] Can't fork: $OS_ERROR\n";
}
if ($pid != 0) {
exit;
}
return;
}
sub __signal_handler {
warn "[INFO] Caught a signal $OS_ERROR\n";
unlink $pidfile if (-f $pidfile);
if (-f $pidfile) {
unlink $pidfile;
}
exit 0;
}

3
bin/fortune_seed.pl
View File

@@ -6,8 +6,7 @@ use warnings;
use utf8;
use open qw(:std :utf8);
use English qw( -no_match_vars );
use vars qw/$VERSION/;
$VERSION = '1.0';
use version; our $VERSION = qw (1.0);
my $workdir;

3
bin/friday_seed.pl
View File

@@ -6,8 +6,7 @@ use warnings;
use utf8;
use open qw(:std :utf8);
use English qw( -no_match_vars );
use vars qw/$VERSION/;
$VERSION = '1.0';
use version; our $VERSION = qw (1.0);
my $workdir;

3
bin/train_lat.pl
View File

@@ -6,8 +6,7 @@ use warnings;
use utf8;
use open qw(:std :utf8);
use English qw( -no_match_vars );
use vars qw/$VERSION/;
$VERSION = '1.0';
use version; our $VERSION = qw (1.0);
my $workdir;

2
confcheck.pl
View File

@@ -9,7 +9,7 @@ use English qw( -no_match_vars );
use lib qw(./lib ./vendor_perl ./vendor_perl/lib/perl5);
use JSON::XS;
use version; our $VERSION = qv(1.0);
use version; our $VERSION = qw (1.0);
my $c = 'data/config.json';
open (my $C, '<', $c) or die "No conf at $c: $OS_ERROR\n";

1
cpanfile
View File

@@ -17,6 +17,7 @@ requires 'local::lib';
requires 'Log::Any';
requires 'Log::Any::Adapter';
requires 'Log::Any::For::Std';
requires 'Math::Random::Secure';
requires 'Mojo::Base';
requires 'Mojo::IOLoop';
requires 'Mojo::UserAgent';

7
data/sample_config.json
View File

@@ -10,16 +10,13 @@
"srcdir" : "data/fortune_src"
},
"telegrambot" : {
"name" : "mybot",
"tname" : "@my_bot",
"csign" : "!",
"token" : "get_it_from_botfather",
"braindir": "data/telegrambot-brains"
},
"openweathermap" : {
"cachetime": "data/cache/openweathermap.Id-Timestamp.db",
"cachedata": "data/cache/openweathermap.Id-Data.db",
"appid": "get_it_on_openweathermap.org"
"appid": "get_it_on_openweathermap.org",
"cachedir" : "data/cache"
},
"lat" : {
"brain": "data/lat/lat.sqlite",

28
lib/archeologist.pm
View File

@@ -4,13 +4,13 @@ use 5.018;
use strict;
use warnings;
use utf8;
use open qw(:std :utf8);
use English qw( -no_match_vars );
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Math::Random::Secure qw (irand);
use vars qw/$VERSION/;
use Exporter qw(import);
our @EXPORT_OK = qw(dig);
$VERSION = '1.0';
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (dig);
sub dig {
my $name = shift;
@@ -100,21 +100,21 @@ sub dig {
'на просторах Украины',
);
my $find_probability = int (rand 100);
my $success_probability = int (rand 100);
my $artifact_age = int (rand 15000);
my $find_probability = irand 101;
my $success_probability = irand 101;
my $artifact_age = irand 15001;
if ($find_probability <= 20) {
return sprintf 'По уши закопавшись %s, %s, нифига вы не выкопали! Может повезет в другом месте?', $location[int (rand ($#location + 1))], $name;
return sprintf 'По уши закопавшись %s, %s, нифига вы не выкопали! Может повезет в другом месте?', $location[irand ($#location + 1)], $name;
}
my $phrase = sprintf "Вы начали раскопки %s и усиленно роете лопатами, экскаватором...\n", $location[int (rand ($#location + 1))];
my $phrase = sprintf "Вы начали раскопки %s и усиленно роете лопатами, экскаватором...\n", $location[irand ($#location + 1)];
$phrase .= "Вам кажется что ваш совочек ударился обо что-то твердое. Может, это клад?!\n\n";
if ($success_probability <= 20) {
$phrase .= sprintf '%s стал лучшим археологом, выкопав %s! возраст артефакта - %s лет!', $name, $artifact[int (rand ($#artifact + 1))], $artifact_age;
if ($success_probability <= 25) {
$phrase .= sprintf '%s стал лучшим археологом, выкопав %s! возраст артефакта - %s лет!', $name, $artifact[irand ($#artifact + 1)], $artifact_age;
} else {
$phrase .= sprintf "Поздравляю, %s! Вы только что выкопали %s, возраст - %s лет!\n", $name, $artifact[int (rand ($#artifact + 1))], $artifact_age;
$phrase .= sprintf "Поздравляю, %s! Вы только что выкопали %s, возраст - %s лет!\n", $name, $artifact[irand ($#artifact + 1)], $artifact_age;
$phrase .= sprintf 'Извини %s, но на артефакт это не тянет! Однако, попытка хорошая!', $name;
}

313
lib/botlib.pm
View File

@@ -5,210 +5,27 @@ use 5.018;
use strict;
use warnings;
use utf8;
use open qw(:std :utf8);
use English qw( -no_match_vars );
use Carp qw(carp);
use HTTP::Tiny;
use URI::URL;
use JSON::XS qw(decode_json encode_json);
use Digest::MD5 qw(md5_base64);
use DB_File;
use Text::Fuzzy qw(distance_edits);
use conf qw(loadConf);
use lat qw(latAnswer);
use karma qw(karmaSet karmaGet);
use friday qw(friday);
use fortune qw(fortune fortune_toggle fortune_status);
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Carp qw (carp);
use Math::Random::Secure qw (irand);
use conf qw (loadConf);
use archeologist qw (dig);
use fortune qw (fortune fortune_toggle fortune_status);
use friday qw (friday);
use karma qw (karmaSet karmaGet);
use kitty qw (kitty);
use lat qw (latAnswer);
use util qw (trim);
use weather qw (weather);
use vars qw/$VERSION/;
use Exporter qw(import);
our @EXPORT_OK = qw(weather trim randomCommonPhrase command highlight botsleep fmatch);
$VERSION = '1.0';
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (randomCommonPhrase command highlight botsleep);
my $c = loadConf();
sub __urlencode {
my $str = shift;
my $urlobj = url $str;
$str = $urlobj->as_string;
$urlobj = undef; undef $urlobj;
return $str;
}
sub trim {
my $str = shift;
return $str if ($str eq '');
while (substr ($str, 0, 1) =~ /^\s$/xms) {
$str = substr ($str, 1);
}
while (substr ($str, -1, 1) =~ /^\s$/xms) {
chop ($str);
}
return $str;
}
sub weather {
my $city = shift;
$city = trim ($city);
return 'Мне нужно ИМЯ города.' if ($city eq '');
return 'Длинновато для названия города.' if (length($city) > 80);
$city = ucfirst ($city);
my $w = __weather ($city);
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;
}
sub __weather {
my $city = shift;
$city = __urlencode ($city);
my $id = md5_base64 ($city);
my $appid = $c->{openweathermap}->{appid};
my $now = time ();
my $fc;
my $w;
# attach to cache data
tie my %cachetime, 'DB_File', $c->{openweathermap}->{cachetime} or do {
carp "[ERROR] Something nasty happen when cachetime ties to its data: $OS_ERROR";
return undef;
};
tie my %cachedata, 'DB_File', $c->{openweathermap}->{cachedata} or do {
carp "[ERROR] Something nasty happen when cachedata ties to its data: $OS_ERROR";
return undef;
};
# lookup cache
if (defined ($cachetime{$id}) && ($now - $cachetime{$id}) < 10800) {
$fc = decode_json ($cachedata{$id});
} else {
my $r;
# try 3 times and giveup
for (1..3) {
next if ($r->{success});
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', $city, $appid));
sleep 2;
}
# all 3 times can give error, so check it here
if ($r->{success}) {
$fc = eval { decode_json ($r->{content}) };
if ($EVAL_ERROR) {
carp "[WARN] openweathermap returns corrupted json: $EVAL_ERROR";
untie %cachetime;
untie %cachedata;
return undef;
};
$cachetime{$id} = $now;
$cachedata{$id} = encode_json ($fc);
} else {
untie %cachetime;
untie %cachedata;
return undef;
}
}
untie %cachetime;
untie %cachedata;
# TODO: check all of this for existance
$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 $c = loadConf ();
my $csign = $c->{telegrambot}->{csign};
sub randomCommonPhrase {
my @myphrase = (
@@ -225,7 +42,7 @@ sub randomCommonPhrase {
'А ви, таки, почему интересуетесь?',
);
return $myphrase[rand ($#myphrase -1)];
return $myphrase[irand ($#myphrase + 1)];
}
sub command {
@@ -250,10 +67,14 @@ sub command {
my $city = substr ($text, 3);
$reply = weather ($city);
} elsif (substr ($text, 1) eq 'cat' || substr ($text, 1) eq 'кис') {
$reply = kitty();
$reply = kitty ();
$msg->typing ();
sleep (int ( rand (2) + 1));
$msg->replyMd ($reply);
return;
} elsif (substr ($text, 1) eq 'lat' || substr ($text, 1) eq 'лат') {
$reply = latAnswer ();
} elsif ((length ($text) >= 6 && (substr ($text, 1, 6) eq 'karma ' || substr ($text, 1, 6) eq 'карма ')) || substr($text, 1) eq 'karma' || substr($text, 1) eq 'карма') {
} 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) {
@@ -282,23 +103,23 @@ sub command {
$msg->replyMd ($reply);
return;
} elsif (substr ($text, 1) eq 'help' || substr ($text, 1) eq 'помощь') {
$reply = << 'MYHELP';
$reply = << "MYHELP";
```
!help | !помощь - список команд
!cat | !кис - кошечка
!dig | !копать - заняться археологией
!f | !ф - рандомная фраза из сборника цитат fortune_mod
!fortune | !фортунка - рандомная фраза из сборника цитат fortune_mod
!f # | !ф # - где 1 - вкл, 0 - выкл фортунку с утра
!fortune # | !фортунка # - где 1 - вкл, 0 - выкл фортунку с утра
!f ? | !ф ? - показываем ли с утра фортунку для чата
!fortune ? | !фортунка ? - показываем ли с утра фортунку для чата
!friday | !пятница - а не пятница ли сегодня?
!lat | !лат - сгенерить фразу из крылатых латинских выражений
!ping | !пинг - попинговать бота
!ver | !version | !версия - что-то про версию ПО
!w город | !п город - погода в указанном городе
!karma фраза | !карма фраза - посмотреть карму фразы
${csign}help | ${csign}помощь - список команд
${csign}cat | ${csign}кис - кошечка
${csign}dig | ${csign}копать - заняться археологией
${csign}f | ${csign}ф - рандомная фраза из сборника цитат fortune_mod
${csign}fortune | ${csign}фортунка - рандомная фраза из сборника цитат fortune_mod
${csign}f # | ${csign}ф # - где 1 - вкл, 0 - выкл фортунку с утра
${csign}fortune # | ${csign}фортунка # - где 1 - вкл, 0 - выкл фортунку с утра
${csign}f ? | ${csign}ф ? - показываем ли с утра фортунку для чата
${csign}fortune ? | ${csign}фортунка ? - показываем ли с утра фортунку для чата
${csign}friday | ${csign}пятница - а не пятница ли сегодня?
${csign}lat | ${csign}лат - сгенерить фразу из крылатых латинских выражений
${csign}ping | ${csign}пинг - попинговать бота
${csign}ver | ${csign}version | ${csign}версия - что-то про версию ПО
${csign}w город | ${csign}п город - погода в указанном городе
${csign}karma фраза | ${csign}карма фраза - посмотреть карму фразы
фраза-- | фраза++ - убавить или добавить карму фразе
```
Но на самом деле я бот больше для общения, чем для исполнения команд.
@@ -319,15 +140,18 @@ sub highlight {
my $username;
my $visavi = '';
my $userid = $msg->from->id;
$username = $msg->from->username if ($msg->from->can ('username') && defined($msg->from->username));
if ($msg->from->can ('first_name') && defined ($msg->from->first_name)) {
if ($msg->from->can ('username') && defined $msg->from->username ) {
$username = $msg->from->username;
}
if ($msg->from->can ('first_name') && defined $msg->from->first_name) {
$fullname = $msg->from->first_name;
if ($msg->from->can ('last_name') && defined ($msg->from->last_name)) {
if ($msg->from->can ('last_name') && defined $msg->from->last_name) {
$fullname .= ' ' . $msg->from->last_name;
}
} elsif ($msg->from->can ('last_name') && defined ($msg->from->last_name)) {
} elsif ($msg->from->can ('last_name') && defined $msg->from->last_name) {
$fullname .= $msg->from->last_name;
}
@@ -358,7 +182,7 @@ sub botsleep {
for (0..(4 + int (rand (3)))) {
$msg->typing ();
sleep(3);
sleep 3;
sleep 3 unless ($_);
}
@@ -366,45 +190,6 @@ sub botsleep {
return;
}
sub fmatch {
my $srcphrase = shift;
my $answer = shift;
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 kitty {
my $r;
for (1..3) {
my $http = HTTP::Tiny->new (timeout => 3);
$r = $http->get ('https://api.thecatapi.com/v1/images/search');
last if ($r->{success});
sleep 2;
}
if ($r->{success}) {
my $jcat = eval { decode_json ($r->{content}) };
if ($jcat->[0]->{url}) {
my @cats = ('龴ↀ◡ↀ龴', '=^..^=', '≧◔◡◔≦ ','^ↀᴥↀ^' );
return sprintf '[%s](%s)', $cats[int(rand($#cats))], $jcat->[0]->{url};
} else {
return 'Нету кошечек, все разбежались.';
}
} else {
return 'Нету кошечек, все разбежались.';
}
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

13
lib/conf.pm
View File

@@ -5,19 +5,18 @@ use 5.018;
use strict;
use warnings;
use utf8;
use open qw(:std :utf8);
use English qw( -no_match_vars );
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use JSON::XS;
use vars qw/$VERSION/;
use Exporter qw(import);
our @EXPORT_OK = qw(loadConf);
$VERSION = '1.0';
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 $len = (stat $c) [7];
my $json;
my $readlen = read $CH, $json, $len;

40
lib/fortune.pm
View File

@@ -5,18 +5,17 @@ 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 open qw (:std :utf8);
use English qw ( -no_match_vars );
use Carp qw (cluck croak);
use File::Path qw (make_path);
use Math::Random::Secure qw (irand);
use SQLite_File;
use MIME::Base64;
use File::Path qw(mkpath);
use conf qw(loadConf);
use conf qw (loadConf);
use vars qw/$VERSION/;
use version; our $VERSION = qw (1.0);
use Exporter qw(import);
our @EXPORT_OK = qw(seed fortune fortune_toggle fortune_toggle_list fortune_status);
$VERSION = '1.0';
my $c = loadConf();
my $dir = $c->{fortune}->{dir};
@@ -24,7 +23,7 @@ my $srcdir = $c->{fortune}->{srcdir};
sub seed () {
unless (-d $dir) {
mkpath ($dir) || croak "Unable to create $dir: $OS_ERROR";
make_path ($dir) || croak "Unable to create $dir: $OS_ERROR";
}
my $backingfile = sprintf '%s/fortune.sqlite', $dir;
@@ -39,14 +38,21 @@ sub seed () {
while (my $fortunefile = readdir ($srcdirhandle)) {
my $srcfile = sprintf '%s/%s', $srcdir, $fortunefile;
next unless (-f $srcfile);
next if ($fortunefile =~ m/\./);
unless (-f $srcfile) {
next;
}
if ($fortunefile =~ m/\./) {
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);
my $phrase = substr $_, 0, -3;
push @fortune, $phrase;
}
@@ -67,7 +73,7 @@ sub fortune () {
return '';
};
my $phrase = $array[int (rand ($#array - 1))];
my $phrase = $array[irand ($#array + 1)];
# decode?
utf8::decode $phrase;
untie @array;
@@ -80,7 +86,7 @@ sub fortune_toggle (@) {
my $phrase = 'Фортунка с утра ';
unless (-d $dir) {
mkpath ($dir) || do {
make_path ($dir) || do {
cluck "[ERROR] Unable to create $dir: $OS_ERROR";
return;
};
@@ -125,7 +131,7 @@ sub fortune_status ($) {
my $phrase = 'Фортунка с утра ';
unless (-d $dir) {
mkpath ($dir) || do {
make_path ($dir) || do {
cluck "[ERROR] Unable to create $dir: $OS_ERROR";
return;
};
@@ -141,7 +147,7 @@ sub fortune_status ($) {
my $state = $toggle{$chatid};
if (defined $state && $state) {
$phrase .= 'показываtтся.';
$phrase .= 'показывается.';
} else {
$phrase .= 'не показывается.';
}
@@ -152,7 +158,7 @@ sub fortune_status ($) {
sub fortune_toggle_list () {
unless (-d $dir) {
mkpath ($dir) || do {
make_path ($dir) || do {
cluck "[ERROR] Unable to create $dir: $OS_ERROR";
my @empty = ();
return @empty;

52
lib/friday.pm
View File

@@ -5,27 +5,26 @@ 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 open qw (:std :utf8);
use English qw ( -no_match_vars );
use Carp qw (cluck croak);
use File::Path qw (make_path);
use Math::Random::Secure qw (irand);
use SQLite_File;
use MIME::Base64;
use File::Path qw(mkpath);
use conf qw(loadConf);
use conf qw (loadConf);
use vars qw/$VERSION/;
use Exporter qw(import);
our @EXPORT_OK = qw(seed friday);
$VERSION = '1.0';
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (seed friday);
my $c = loadConf();
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) {
mkpath ($dir) || croak "Unable to create $dir: $OS_ERROR";
make_path ($dir) || croak "Unable to create $dir: $OS_ERROR";
}
my $friday;
@@ -43,27 +42,41 @@ sub seed () {
open (my $fh, '<', $srcfile) || croak "Unable to open $srcfile, $OS_ERROR\n";
while (readline $fh) {
next unless m/ \|\| /xmsg;
unless (m/ \|\| /xmsg) {
next;
}
chomp();
my ($phrase, $days) = split(/ \|\| /);
my @daylist = split(//, $days);
foreach my $day (@daylist) {
next unless (defined $day);
next unless ($day =~ /^\d$/);
push @{$friday->[$day - 1]}, $phrase if (defined $phrase && ($phrase ne '') && ($phrase !~ m/^\s+$/xmsg));
unless (defined $day) {
next;
}
unless ($day =~ /^\d$/) {
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->[$_]; }
for (0..$#dow) {
untie $friday->[$_];
}
return;
}
# just return answer
sub friday () {
my $today = (localtime(time))[6] - 1;
my $today = (localtime (time))[6] - 1;
my $backingfile = sprintf '%s/%s.sqlite', $dir, $dow[$today];
tie my @array, 'SQLite_File', $backingfile || do {
@@ -71,8 +84,7 @@ sub friday () {
return '';
};
my $phrase = $array[int (rand ($#array - 1))];
# decode?
my $phrase = $array[irand ($#array + 1)];
utf8::decode $phrase;
untie @array;
return $phrase;

34
lib/karma.pm
View File

@@ -4,17 +4,17 @@ use 5.018;
use strict;
use warnings;
use utf8;
use open qw(:std :utf8);
use English qw( -no_match_vars );
use Digest::SHA qw(sha1_base64);
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Carp qw (cluck);
use Digest::SHA qw (sha1_base64);
use DB_File;
use Carp qw(cluck);
use conf qw(loadConf);
use File::Path qw (make_path);
use conf qw (loadConf);
use vars qw/$VERSION/;
use Exporter qw(import);
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw(karmaSet karmaGet);
$VERSION = '1.0';
my $c = loadConf();
my $karmadir = $c->{karma}->{dir};
@@ -28,7 +28,7 @@ sub karmaSet (@) {
my $score = 0;
# sha1* does not understand utf8, so explicitly construct string cost of decimal numbers only
my $karmafile = join ('', unpack ('C*', $chatid));
$karmafile = sha1_base64 ($karmafile);
$karmafile = sha1_base64 $karmafile;
# sha1 string can contain slashes, so make a bit longer string consist of only decimal numbers
$karmafile = join ('', unpack ('C*', $karmafile));
$karmafile = sprintf '%s/%s.db', $karmadir, $karmafile;
@@ -37,6 +37,13 @@ sub karmaSet (@) {
$phrase = '';
}
unless (-d $karmadir) {
make_path ($karmadir) or do {
cluck "Unable to create $karmadir: $OS_ERROR";
return sprintf 'Карма %s составляет 0', $phrase;
};
}
# init hash, store phrase and score
tie my %karma, 'DB_File', $karmafile || do {
cluck "[ERROR] Something nasty happen when cachedata ties to its data: $OS_ERROR";
@@ -87,7 +94,7 @@ sub karmaGet (@) {
my $phrase = shift;
# sha1* does not understand utf8, so explicitly construct string cost of decimal numbers only
my $karmafile = join ('', unpack ('C*', $chatid));
$karmafile = sha1_base64 ($karmafile);
$karmafile = sha1_base64 $karmafile;
# sha1 string can contain slashes, so make a bit longer string consist of only decimal numbers
$karmafile = join ('', unpack ('C*', $karmafile));
$karmafile = sprintf '%s/%s.db', $karmadir, $karmafile;
@@ -96,6 +103,13 @@ sub karmaGet (@) {
$phrase = '';
}
unless (-d $karmadir) {
make_path ($karmadir) or do {
cluck "Unable to create $karmadir: $OS_ERROR";
return sprintf 'Карма %s составляет 0', $phrase;
};
}
# init hash, store phrase and score
tie my %karma, 'DB_File', $karmafile || do {
cluck "[ERROR] Something nasty happen when karma ties to its data: $OS_ERROR";

55
lib/kitty.pm Normal file
View File

@@ -0,0 +1,55 @@
package kitty;
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 JSON::XS;
use HTTP::Tiny;
use Math::Random::Secure qw (irand);
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})
};
if ($EVAL_ERROR) {
cluck "[ERROR] Unable to decode JSON: $EVAL_ERROR";
} else {
if ($jcat->[0]->{url}) {
my @cats = ('龴ↀ◡ↀ龴', '=^..^=', '≧◔◡◔≦ ','^ↀᴥↀ^' );
$ret = sprintf '[%s](%s)', $cats[irand ($#cats + 1)], $jcat->[0]->{url};
}
}
} else {
cluck 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:

33
lib/lat.pm
View File

@@ -5,28 +5,27 @@ 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 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 File::Basename qw(dirname);
use File::Path qw(mkpath);
use conf qw(loadConf);
use conf qw (loadConf);
use vars qw/$VERSION/;
use Exporter qw(import);
our @EXPORT_OK = qw(train latAnswer);
$VERSION = '1.0';
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (train latAnswer);
my $c = loadConf();
my $c = loadConf ();
my $brain = $c->{lat}->{brain};
my $srcfile = $c->{lat}->{src};
sub train () {
my $braindir = dirname ($brain);
my $braindir = dirname $brain;
unless (-d $braindir) {
mkpath ($braindir) or do {
make_path ($braindir) or do {
cluck "Unable to create $braindir: $OS_ERROR";
exit 1;
};
@@ -38,8 +37,8 @@ sub train () {
order => 2
);
$lat->train($srcfile);
my ($tokens, $expressions) = ($lat->stats())[0,1];
$lat->train ($srcfile);
my ($tokens, $expressions) = ($lat->stats ())[0,1];
printf "Total tokens: %s\nTotal expressins: %s\n", $tokens, $expressions;
$lat->save ();
return;
@@ -47,7 +46,7 @@ sub train () {
# just return answer
sub latAnswer () {
my $braindir = dirname ($brain);
my $braindir = dirname $brain;
unless (-d $braindir) {
cluck "[ERROR] No lat module data: $braindir is absent! Train lat first.";
@@ -66,7 +65,7 @@ sub latAnswer () {
save_on_exit => 0
);
return $lat->reply();
return $lat->reply ();
}
1;

38
lib/telegrambot.pm
View File

@@ -6,22 +6,23 @@ use strict;
use warnings;
use utf8;
use Data::Dumper;
use open qw(:std :utf8);
use Carp qw(carp);
use File::Path qw(mkpath);
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Carp qw (cluck carp);
use File::Path qw (make_path);
use Hailo;
use Mojo::Base 'Teapot::Bot::Brain';
use conf qw(loadConf);
use botlib qw(weather trim randomCommonPhrase command highlight botsleep fmatch);
use karma qw(karmaSet);
use fortune qw(fortune fortune_toggle_list);
use botlib qw (randomCommonPhrase command highlight botsleep);
use conf qw (loadConf);
use fortune qw (fortune fortune_toggle_list);
use karma qw (karmaSet);
use util qw (trim fmatch);
use vars qw/$VERSION/;
use Exporter qw(import);
our @EXPORT_OK = qw(run_telegrambot);
$VERSION = '1.0';
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (run_telegrambot);
my $c = loadConf();
my $c = loadConf ();
my $hailo;
my $myid;
my $myusername;
@@ -241,7 +242,7 @@ sub __on_msg {
} elsif ((lc ($text) =~ /.+ ${qtname}[\,|\!|\?|\.| ]/) or (lc ($text) =~ / $qtname$/)) {
$phrase = $text;
$reply = $hailo->{$msg->chat->id}->reply ($phrase);
# karma agjustment
# karma adjustment
} elsif (substr ($text, -2) eq '++' || substr ($text, -2) eq '--') {
my @arr = split(/\n/, $text);
@@ -289,11 +290,16 @@ sub __on_msg {
# setup our bot
sub init {
unless (-d $c->{telegrambot}->{braindir}) {
mkpath ($c->{telegrambot}->{braindir}, 0, 0755); ## no critic (ValuesAndExpressions::ProhibitLeadingZeros)
my $self = shift;
my $braindir = $c->{telegrambot}->{braindir};
unless (-d $braindir) {
make_path ($braindir, 0, 0755) or do { ## no critic (ValuesAndExpressions::ProhibitLeadingZeros)
cluck "Unable to create $braindir: $OS_ERROR";
exit 1;
};
}
my $self = shift;
$self->add_listener (\&__on_msg);
$self->add_repeating_task (900, \&__cron);
return;

83
lib/util.pm Normal file
View File

@@ -0,0 +1,83 @@
package util;
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
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;
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;
my $urlobj = url $str;
return $urlobj->as_string;
}
sub fmatch {
my $srcphrase = shift;
my $answer = shift;
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;
if ($string eq '') {
return encode_base64 '';
}
my $bytes = encode_utf8 $string;
return encode_base64 $bytes;
}
sub utf2sha1 {
my $string = shift;
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:

200
lib/weather.pm Normal file
View File

@@ -0,0 +1,200 @@
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 DB_File;
use Digest::MD5 qw (md5_base64);
use File::Path qw (make_path);
use HTTP::Tiny;
use JSON::XS;
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 $w = __weather ($city);
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;
}
sub __weather {
my $city = shift;
$city = urlencode $city;
my $id = md5_base64 $city;
my $appid = $c->{openweathermap}->{appid};
my $cachedir = $c->{openweathermap}->{cachedir};
my $cachetimefile = $cachedir . '/openweathermap.Id-Timestamp.db';
my $cachedatafile = $cachedir . '/openweathermap.Id-Data.db';
my $now = time ();
my $fc;
my $w;
unless (-d $cachedir) {
make_path ($cachedir) || do {
cluck "[ERROR] Unable to create $cachedir: $OS_ERROR";
return;
};
}
# attach to cache data
tie my %cachetime, 'DB_File', $cachetimefile or do {
carp "[ERROR] Something nasty happen when cachetime ties to its data: $OS_ERROR";
return undef;
};
tie my %cachedata, 'DB_File', $cachedatafile or do {
carp "[ERROR] Something nasty happen when cachedata ties to its data: $OS_ERROR";
return undef;
};
# lookup cache
if (defined ($cachetime{$id}) && ($now - $cachetime{$id}) < 10800) {
$fc = decode_json $cachedata{$id};
} else {
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', $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};
};
if ($EVAL_ERROR) {
cluck "[WARN] openweathermap returns corrupted json: $EVAL_ERROR";
untie %cachetime;
untie %cachedata;
return undef;
};
$cachetime{$id} = $now;
$cachedata{$id} = encode_json $fc;
} else {
cluck sprintf 'Server return status %s with message: %s', $r->{status}, $r->{reason};
untie %cachetime;
untie %cachedata;
return undef;
}
}
untie %cachetime;
untie %cachedata;
# TODO: check all of this for existance
$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;
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4: