Refactor code. Fix some bugs.

+ Use lazy brain init. * Move plugin code out of botlib.pm. + Now bot can private chatting * Properly detect real jid if can, extract username from jid * Change chatid generation, so all previously generated brains will be lost + Add !dig and !копать commands + Add !cat and !кис commands * Some other minor changes
2021-01-07 16:13:29 +03:00
parent 4c7cf8ceca
commit b4a1bf66cf
15 changed files with 1038 additions and 428 deletions
--- a/lib/botlib.pm
+++ b/lib/botlib.pm
@@ -4,202 +4,26 @@ 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 conf qw(loadConf);
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use Carp qw (carp);
+use archeologist qw (dig);
+use conf qw (loadConf);
+use fortune qw (fortune);
+use friday qw (friday);
+use karma qw (karmaGet);
+use kitty qw (kitty);
+use lat qw (latAnswer);
+use util qw (trim utf2sha1);
+use weather qw (weather);

 use vars qw/$VERSION/;
 use Exporter qw(import);
-our @EXPORT_OK = qw(weather trim randomCommonPhrase);
+our @EXPORT_OK = qw(command randomCommonPhrase realjid);
 $VERSION = '1.0';

 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 $now = time ();
-	my $fc;
-	my $w;
-
-# attach to cache data
-	tie my %cachetime, 'DB_File', $c->{openweathermap}->{cachetime} or do {
-		carp "Something nasty happen when cachetime ties to its data: $OS_ERROR";
-		return undef;
-	};
-
-	tie my %cachedata, 'DB_File', $c->{openweathermap}->{cachedata} or do {
-		carp "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;
-}
-
-sub __urlencode($) {
-	my $str = shift;
-	my $urlobj = url $str;
-	$str = $urlobj->as_string;
-	$urlobj = undef; undef $urlobj;
-	return $str;
-}
-
-sub trim ($) {
-	my $str = shift;
-
-	while (substr ($str, 0, 1) =~ /^\s$/) {
-		$str = substr($str, 1);
-	}
-
-	while (substr ($str, -1, 1) =~ /^\s$/) {
-		chop ($str);
-	}
-
-	return $str;
-}
-
 sub randomCommonPhrase () {
 	my @myphrase = (
 		'Так, блядь...',
@@ -214,7 +38,272 @@ sub randomCommonPhrase () {
 		'А как ты думаешь?',
 	);

-	return $myphrase[rand($#myphrase -1)];
+	return $myphrase[int (rand ($#myphrase + 1))];
+}
+
+sub command {
+	my %hash = @_;
+	my $bot = $hash{bot_object};
+	my $text = $hash{body};
+	my %jid = realjid (%hash);
+	my $chattername = $jid{'name'};
+	my $chatid;
+
+	if ($hash{'type'} eq 'groupchat') {
+		$chatid = utf2sha1 $hash{'reply_to'};
+	} else {
+		$chatid = utf2sha1 $jid{'name'};
+	}
+
+	$chatid =~ s/\//-/xmsg;
+	%jid = (); undef %jid;
+	my $csign = $c->{jabberbot}->{aleesa}->{csign};
+
+	my $reply;
+
+	if (substr ($text, 1, 3) eq 'rum' || substr ($text, 1, 3) eq 'ром') {
+		my $target;
+
+		if (($hash{'type'} eq 'groupchat') && (length ($text) > 5)) {
+			$target = trim (substr $text, 5);
+		}
+
+		if (! defined $target || ($target eq '')) {
+			$target = $chattername;
+		}
+
+		$reply = '/me притаскивает на подносе стопку рома для ' . $target . ', края стопки искрятся кристаллами соли.';
+	} elsif (substr ($text, 1, 5) eq 'vodka' || substr ($text, 1, 5) eq 'водка') {
+		my $target;
+
+		if (($hash{'type'} eq 'groupchat') && (length ($text) > 7)) {
+			$target = trim (substr $text, 7);
+		}
+
+		if (! defined $target || ($target eq '')) {
+			$target = $chattername;
+		}
+
+		$reply = '/me подаёт шот водки с небольшим маринованным огурчиком на блюдце для ' . $target . '. Из огурчика торчит небольшая вилочка.';
+	} elsif (substr ($text, 1, 4) eq 'beer' || substr ($text, 1, 4) eq 'пиво') {
+		my $target;
+
+		if (($hash{'type'} eq 'groupchat') && (length ($text) > 6)) {
+			$target = trim (substr $text, 6);
+		}
+
+		if (! defined $target || ($target eq '')) {
+			$target = $chattername;
+		}
+
+		$reply = '/me бахает об стол перед ' . $target . ' кружкой холодного пива, часть пенной шапки сползает по запотевшей стенке кружки.';
+	} elsif (substr ($text, 1, 7) eq 'tequila') {
+		my $target;
+
+		if (($hash{'type'} eq 'groupchat') && (length ($text) > 9)) {
+			$target = trim (substr $text, 9);
+		}
+
+		if (! defined $target || ($target eq '')) {
+			$target = $chattername;
+		}
+
+		$reply = '/me ставит рядом с ' . $target . ' шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли.';
+	} elsif (substr ($text, 1, 6) eq 'текила') {
+		my $target;
+
+		if (($hash{'type'} eq 'groupchat') && (length ($text) > 8)) {
+			$target = trim (substr $text, 8);
+		}
+
+		if (! defined $target || ($target eq '')) {
+			$target = $chattername;
+		}
+
+		$reply = '/me ставит рядом с ' . $target . ' шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли.';
+	} elsif (substr ($text, 1, 6) eq 'whisky') {
+		my $target;
+
+		if (($hash{'type'} eq 'groupchat') && (length ($text) > 8)) {
+			$target = trim (substr $text, 8);
+		}
+
+		if (! defined $target || ($target eq '')) {
+			$target = $chattername;
+		}
+
+		$reply = '/me демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около ' . $target . '.';
+	} elsif (substr ($text, 1, 5) eq 'виски') {
+		my $target;
+
+		if (($hash{'type'} eq 'groupchat') && (length ($text) > 7)) {
+			$target = trim (substr $text, 7);
+		}
+
+		if (! defined $target || ($target eq '')) {
+			$target = $chattername;
+		}
+
+		$reply = '/me демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около ' . $target . '.';
+	} elsif (substr ($text, 1, 8) eq 'absinthe') {
+		my $target;
+
+		if (($hash{'type'} eq 'groupchat') && (length ($text) > 10)) {
+			$target = trim (substr $text, 10);
+		}
+
+		if (! defined $target || ($target eq '')) {
+			$target = $chattername;
+		}
+
+		$reply = '/me наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, ' . $bot->{'alias'} . ' размешивает оплавившийся кубик в абсенте и подносит стопку ' . $target . '.';
+	} elsif (substr ($text, 1, 6) eq 'абсент') {
+		my $target;
+
+		if (($hash{'type'} eq 'groupchat') && (length ($text) > 8)) {
+			$target = trim (substr $text, 8);
+		}
+
+		if (! defined $target || ($target eq '')) {
+			$target = $chattername;
+		}
+
+		$reply = '/me наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, ' . $bot->{'alias'} . ' размешивает оплавившийся кубик в абсенте и подносит стопку ' . $target . '.';
+	} 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 'version'  ||  substr ($text, 1) eq 'ver') {
+		$reply = 'Версия нуль.чего-то_там.чего-то_там';
+	} elsif (substr ($text, 1) eq 'help'  ||  substr ($text, 1) eq 'помощь') {
+		$reply = <<"EOL";
+
+${csign}help | ${csign}помощь      - это сообщение
+${csign}cat | ${csign}кис          - кошечка
+${csign}dig | ${csign}копать       - заняться археологией
+${csign}f | ${csign}ф              - рандомная фраза из сборника цитат fortune_mod
+${csign}fortune | ${csign}фортунка - рандомная фраза из сборника цитат fortune_mod
+${csign}friday | ${csign}пятница   - а не пятница ли сегодня?
+${csign}karma фраза         - посмотреть карму фразы
+${csign}карма фраза         - посмотреть карму фразы
+фраза++ | фраза--    - повысить или понизить карму фразы
+${csign}lat | ${csign}лат          - сгенерировать фразу из крылатого латинского выражения
+${csign}ping | ${csign}пинг        - попинговать бота
+${csign}some_brew           - выдать соответствующий напиток, бармен может налить rum, ром, vodka, водку, beer, пиво, tequila, текила, whisky, виски, absinthe, абсент
+${csign}ver | ${csign}version      - написать что-то про версию ПО
+${csign}версия              - написать что-то про версию ПО
+${csign}w город | ${csign}п город  - погода в городе
+EOL
+
+	} elsif (substr ($text, 1) eq 'lat'  ||  substr ($text, 1) eq 'лат') {
+		$reply = latAnswer ();
+	} elsif (substr ($text, 1) eq 'cat'  ||  substr ($text, 1) eq 'кис') {
+		$reply = kitty ();
+	} elsif (substr ($text, 1) eq 'dig'  ||  substr ($text, 1) eq 'копать') {
+		$reply = dig ($chattername);
+	} 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 'fortune'  ||  substr ($text, 1) eq 'фортунка'  ||  substr ($text, 1) eq 'f'  ||  substr ($text, 1) eq 'ф') {
+		my $phrase = fortune ();
+		# workaround Net::Jabber::Bot outgoing message ![:print:] replacement
+		$phrase =~ s/\s\s+\-\-/\n \-\-/xmsg;
+		$reply = $phrase;
+	} elsif (substr ($text, 1) eq 'ping') {
+		$reply = 'Pong.';
+	} elsif (substr ($text, 1) eq 'пинг') {
+		$reply = 'Понг.';
+	}
+
+	return $reply;
+}
+
+# in this particular case real jid is really hidden :) and i hope that i found where it is seaking.
+sub realjid {
+	my %hash = @_;
+	my $bot = $hash{'bot_object'};
+	my $myjid = $hash{'from_full'}; # in case of real jid myjid is name@server/resource in case of "groupchat" jid it is group@conf_server/name
+	my $presencedb = $bot->{'jabber_client'}->{'PRESENCEDB'};
+	my %result;
+
+	# there is missing case where user' name part of jid same as chat name (sic!)
+
+	# in case of groupchat we have to compare reply_to and 1-st part of myjid (one that before slash)
+	# in case 1-on-1 chat we have to compare 2-nd component of myjid (that between @ and /) and conference server
+	#    assuming that bot sits only on same conference server where bot is registered
+	if (
+			(($hash{'reply_to'} eq (split (/\//, $myjid))[0]) && ($hash{'type'} eq 'groupchat')) ||
+			(($bot->{'conference_server'} eq (split (/\@/, (split (/\//, $myjid))[0]))[1]) && ($hash{'type'} eq 'chat'))
+		) {
+		foreach my $knownjid (keys %{$presencedb}) {
+			foreach my $prionum (keys %{$presencedb->{$knownjid}->{'priorities'}}) {
+				foreach my $presence (@{$presencedb->{$knownjid}->{'priorities'}->{$prionum}}) {
+					if ($presence->{'presence'}->{'TREE'}->{'ATTRIBS'}->{'from'} eq $myjid) {
+						foreach my $child (@{$presence->{'presence'}->{'TREE'}->{'CHILDREN'}}) {
+							() = eval {
+								$child->{'CHILDREN'};
+							};
+
+							unless ($EVAL_ERROR) {
+								foreach my $subchild ($child->{'CHILDREN'}) {
+									foreach my $elem (@{$subchild}) {
+										() = eval {
+											$elem->{'ATTRIBS'};
+										};
+
+										unless ($EVAL_ERROR) {
+											() = eval {
+												$elem->{'ATTRIBS'}->{'jid'};
+											};
+
+											unless ($EVAL_ERROR) {
+												if (defined $elem->{'ATTRIBS'}->{'jid'}) {
+													%result = (
+														'fulljid' => $elem->{'ATTRIBS'}->{'jid'},
+														'jid' => (split (/\//, $elem->{'ATTRIBS'}->{'jid'})) [0],
+														'name' => (split (/\@/, $elem->{'ATTRIBS'}->{'jid'})) [0],
+													);
+
+													return %result;
+												}
+											}
+										}
+									}
+								}
+							}
+						}
+					}
+				}
+			}
+		}
+
+		# we tried hard :( and if we here, assume that we have no permissions to to guess real jid in chat
+		%result = (
+			'fulljid' => $myjid,
+			'jid' => $myjid,
+			'name' => (split (/\//, $myjid))[1],
+		);
+	} else {
+		# looks like it is correct real jid, assume that conference server and main server are woking on different domains
+		# at least i hope that this assumption correct
+		%result = (
+			'fulljid' => $myjid,
+			'jid' => (split (/\//, $myjid))[0],
+			'name' => (split (/\@/, $myjid))[0],
+		);
+	}
+
+	return %result;
 }

 1;