Initial commit. Split bot from myapi as separate application.
This commit is contained in:
eleksir
4
.gitignore
vendored
Normal file
4
.gitignore
vendored
Normal file
@@ -0,0 +1,4 @@
|
|||||||
|
vendor_perl/**
|
||||||
|
data/config.json
|
||||||
|
data/*.sqlite
|
||||||
|
data/cache
|
||||||
127
LICENSE
Normal file
127
LICENSE
Normal file
@@ -0,0 +1,127 @@
|
|||||||
|
The "Artistic License"
|
||||||
|
|
||||||
|
Preamble
|
||||||
|
|
||||||
|
The intent of this document is to state the conditions under which a
|
||||||
|
Package may be copied, such that the Copyright Holder maintains some
|
||||||
|
semblance of artistic control over the development of the package,
|
||||||
|
while giving the users of the package the right to use and distribute
|
||||||
|
the Package in a more-or-less customary fashion, plus the right to make
|
||||||
|
reasonable modifications.
|
||||||
|
|
||||||
|
Definitions:
|
||||||
|
|
||||||
|
"Package" refers to the collection of files distributed by the
|
||||||
|
Copyright Holder, and derivatives of that collection of files
|
||||||
|
created through textual modification.
|
||||||
|
|
||||||
|
"Standard Version" refers to such a Package if it has not been
|
||||||
|
modified, or has been modified in accordance with the wishes
|
||||||
|
of the Copyright Holder as specified below.
|
||||||
|
|
||||||
|
"Copyright Holder" is whoever is named in the copyright or
|
||||||
|
copyrights for the package.
|
||||||
|
|
||||||
|
"You" is you, if you're thinking about copying or distributing
|
||||||
|
this Package.
|
||||||
|
|
||||||
|
"Reasonable copying fee" is whatever you can justify on the
|
||||||
|
basis of media cost, duplication charges, time of people involved,
|
||||||
|
and so on. (You will not be required to justify it to the
|
||||||
|
Copyright Holder, but only to the computing community at large
|
||||||
|
as a market that must bear the fee.)
|
||||||
|
|
||||||
|
"Freely Available" means that no fee is charged for the item
|
||||||
|
itself, though there may be fees involved in handling the item.
|
||||||
|
It also means that recipients of the item may redistribute it
|
||||||
|
under the same conditions they received it.
|
||||||
|
|
||||||
|
1. You may make and give away verbatim copies of the source form of the
|
||||||
|
Standard Version of this Package without restriction, provided that you
|
||||||
|
duplicate all of the original copyright notices and associated disclaimers.
|
||||||
|
|
||||||
|
2. You may apply bug fixes, portability fixes and other modifications
|
||||||
|
derived from the Public Domain or from the Copyright Holder. A Package
|
||||||
|
modified in such a way shall still be considered the Standard Version.
|
||||||
|
|
||||||
|
3. You may otherwise modify your copy of this Package in any way, provided
|
||||||
|
that you insert a prominent notice in each changed file stating how and
|
||||||
|
when you changed that file, and provided that you do at least ONE of the
|
||||||
|
following:
|
||||||
|
|
||||||
|
a) place your modifications in the Public Domain or otherwise make them
|
||||||
|
Freely Available, such as by posting said modifications to Usenet or
|
||||||
|
an equivalent medium, or placing the modifications on a major archive
|
||||||
|
site such as uunet.uu.net, or by allowing the Copyright Holder to include
|
||||||
|
your modifications in the Standard Version of the Package.
|
||||||
|
|
||||||
|
b) use the modified Package only within your corporation or organization.
|
||||||
|
|
||||||
|
c) rename any non-standard executables so the names do not conflict
|
||||||
|
with standard executables, which must also be provided, and provide
|
||||||
|
a separate manual page for each non-standard executable that clearly
|
||||||
|
documents how it differs from the Standard Version.
|
||||||
|
|
||||||
|
d) make other distribution arrangements with the Copyright Holder.
|
||||||
|
|
||||||
|
4. You may distribute the programs of this Package in object code or
|
||||||
|
executable form, provided that you do at least ONE of the following:
|
||||||
|
|
||||||
|
a) distribute a Standard Version of the executables and library files,
|
||||||
|
together with instructions (in the manual page or equivalent) on where
|
||||||
|
to get the Standard Version.
|
||||||
|
|
||||||
|
b) accompany the distribution with the machine-readable source of
|
||||||
|
the Package with your modifications.
|
||||||
|
|
||||||
|
c) give non-standard executables non-standard names, and clearly
|
||||||
|
document the differences in manual pages (or equivalent), together
|
||||||
|
with instructions on where to get the Standard Version.
|
||||||
|
|
||||||
|
d) make other distribution arrangements with the Copyright Holder.
|
||||||
|
|
||||||
|
5. You may charge a reasonable copying fee for any distribution of this
|
||||||
|
Package. You may charge any fee you choose for support of this
|
||||||
|
Package. You may not charge a fee for this Package itself. However,
|
||||||
|
you may distribute this Package in aggregate with other (possibly
|
||||||
|
commercial) programs as part of a larger (possibly commercial) software
|
||||||
|
distribution provided that you do not advertise this Package as a
|
||||||
|
product of your own. You may embed this Package's interpreter within
|
||||||
|
an executable of yours (by linking); this shall be construed as a mere
|
||||||
|
form of aggregation, provided that the complete Standard Version of the
|
||||||
|
interpreter is so embedded.
|
||||||
|
|
||||||
|
6. The scripts and library files supplied as input to or produced as
|
||||||
|
output from the programs of this Package do not automatically fall
|
||||||
|
under the copyright of this Package, but belong to whoever generated
|
||||||
|
them, and may be sold commercially, and may be aggregated with this
|
||||||
|
Package. If such scripts or library files are aggregated with this
|
||||||
|
Package via the so-called "undump" or "unexec" methods of producing a
|
||||||
|
binary executable image, then distribution of such an image shall
|
||||||
|
neither be construed as a distribution of this Package nor shall it
|
||||||
|
fall under the restrictions of Paragraphs 3 and 4, provided that you do
|
||||||
|
not represent such an executable image as a Standard Version of this
|
||||||
|
Package.
|
||||||
|
|
||||||
|
7. C subroutines (or comparably compiled subroutines in other
|
||||||
|
languages) supplied by you and linked into this Package in order to
|
||||||
|
emulate subroutines and variables of the language defined by this
|
||||||
|
Package shall not be considered part of this Package, but are the
|
||||||
|
equivalent of input as in Paragraph 6, provided these subroutines do
|
||||||
|
not change the language in any way that would cause it to fail the
|
||||||
|
regression tests for the language.
|
||||||
|
|
||||||
|
8. Aggregation of this Package with a commercial distribution is always
|
||||||
|
permitted provided that the use of this Package is embedded; that is,
|
||||||
|
when no overt attempt is made to make this Package's interfaces visible
|
||||||
|
to the end user of the commercial distribution. Such use shall not be
|
||||||
|
construed as a distribution of this Package.
|
||||||
|
|
||||||
|
9. The name of the Copyright Holder may not be used to endorse or promote
|
||||||
|
products derived from this software without specific prior written permission.
|
||||||
|
|
||||||
|
10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
|
||||||
|
IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
|
||||||
|
WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
|
||||||
|
|
||||||
|
The End
|
||||||
31
README.md
Normal file
31
README.md
Normal file
@@ -0,0 +1,31 @@
|
|||||||
|
# Aleesa-Jabber-bot - Simple Jabber chatty bot
|
||||||
|
|
||||||
|
## About
|
||||||
|
|
||||||
|
It is based on Perl modules [Net::Jabber::Bot][1] and [Hailo][2] as
|
||||||
|
conversation generator.
|
||||||
|
|
||||||
|
Config located in **data/config.json**, sample config provided as
|
||||||
|
**data/sample_config.json**.
|
||||||
|
|
||||||
|
Bot can be run via **bin/aleesa-jabber-bot** and acts as daemon.
|
||||||
|
|
||||||
|
## Installation
|
||||||
|
|
||||||
|
In order to run this application, you need to "bootstrap" it - download and
|
||||||
|
install all dependencies and libraries.
|
||||||
|
|
||||||
|
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:
|
||||||
|
|
||||||
|
```bash
|
||||||
|
bash bootstrap.sh
|
||||||
|
```
|
||||||
|
|
||||||
|
and all libraries should be downloaded, built, tested and installed.
|
||||||
|
|
||||||
|
[1]: https://metacpan.org/pod/Net::Jabber::Bot
|
||||||
|
[2]: https://metacpan.org/pod/Hailo
|
||||||
114
bin/aleesa-jabber-bot
Executable file
114
bin/aleesa-jabber-bot
Executable file
@@ -0,0 +1,114 @@
|
|||||||
|
#!/usr/bin/perl
|
||||||
|
|
||||||
|
use 5.018;
|
||||||
|
use strict;
|
||||||
|
use warnings "all";
|
||||||
|
use utf8;
|
||||||
|
use open qw(:std :utf8);
|
||||||
|
|
||||||
|
my $workdir;
|
||||||
|
|
||||||
|
# before we run, change working dir
|
||||||
|
BEGIN {
|
||||||
|
use Cwd qw(chdir abs_path);
|
||||||
|
my @CWD = split (/\//, abs_path ($0));
|
||||||
|
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 conf qw(loadConf);
|
||||||
|
use botlib qw(logger);
|
||||||
|
use jabberbot qw(run_jabberbot);
|
||||||
|
|
||||||
|
sub daemonize ();
|
||||||
|
sub __fork ();
|
||||||
|
|
||||||
|
$| = 1;
|
||||||
|
my $runAsUid = $<;
|
||||||
|
|
||||||
|
my $piddir = "/var/run/" . basename (abs_path ($0));
|
||||||
|
my $C = loadConf ();
|
||||||
|
|
||||||
|
# if we run under root, create pid dir and set correct owner for it, same for debug log if it is defined
|
||||||
|
if ($< == 0) {
|
||||||
|
my $user = $C->{user};
|
||||||
|
die "Unable to run as root, please define unprivileged user in config.json\n" unless (defined ($user));
|
||||||
|
my ($uid, $gid) = (getpwnam ($user))[2,3];
|
||||||
|
|
||||||
|
unless (-d $piddir) {
|
||||||
|
make_path (
|
||||||
|
$piddir, {
|
||||||
|
uid => $uid,
|
||||||
|
group => $gid
|
||||||
|
}
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
|
if ($C->{'debug_log'}) {
|
||||||
|
unless (-d dirname($C->{'debug_log'})) {
|
||||||
|
make_path (
|
||||||
|
dirname($C->{'debug_log'}), {
|
||||||
|
uid => $uid,
|
||||||
|
group => $gid
|
||||||
|
}
|
||||||
|
);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
# drop privs
|
||||||
|
setgid ($gid) or die "Unable to switch to group of $user($!)\n";
|
||||||
|
setuid ($uid) or die "Unable to switch to account $user($!)\n";
|
||||||
|
} else {
|
||||||
|
$piddir = $workdir;
|
||||||
|
}
|
||||||
|
|
||||||
|
# double fork attach to /dev/null all stdio and go background
|
||||||
|
daemonize ();
|
||||||
|
|
||||||
|
# write pidfile
|
||||||
|
my $apath = abs_path ($0);
|
||||||
|
|
||||||
|
unless (defined($apath)) {
|
||||||
|
logger ("Unable to get abs_path: $!");
|
||||||
|
die "Unable to get abs_path: $!\n";
|
||||||
|
};
|
||||||
|
|
||||||
|
my $pidfile = sprintf ("%s/%s.pid", $piddir, basename ($apath));
|
||||||
|
logger ("Creating pidfile at $pidfile");
|
||||||
|
open (PID, ">", $pidfile) or die "Error opening $pidfile: $!\n";
|
||||||
|
print PID $$ or die "Error writing to $pidfile: $!\n";
|
||||||
|
close PID;
|
||||||
|
|
||||||
|
# set correct proctitle
|
||||||
|
$0 = abs_path ($0);
|
||||||
|
|
||||||
|
# run bot, at last
|
||||||
|
run_jabberbot ();
|
||||||
|
unlink ($pidfile) if (-f $pidfile);
|
||||||
|
exit 0;
|
||||||
|
|
||||||
|
sub daemonize () {
|
||||||
|
__fork ();
|
||||||
|
POSIX::setsid ();
|
||||||
|
open (STDIN, "<", "/dev/null");
|
||||||
|
open (STDOUT, ">", "/dev/null");
|
||||||
|
open (STDERR, ">", "/dev/null");
|
||||||
|
__fork ();
|
||||||
|
umask 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub __fork () {
|
||||||
|
my $pid = fork;
|
||||||
|
die "Can't fork: $!\n" unless (defined ($pid));
|
||||||
|
exit if ($pid != 0);
|
||||||
|
}
|
||||||
|
|
||||||
|
__END__
|
||||||
|
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||||
5
bootstrap.sh
Normal file
5
bootstrap.sh
Normal file
@@ -0,0 +1,5 @@
|
|||||||
|
#!/bin/bash
|
||||||
|
|
||||||
|
cpanm -l vendor_perl --self-contained --force --update --installdeps .
|
||||||
|
|
||||||
|
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||||
35
confcheck.pl
Executable file
35
confcheck.pl
Executable file
@@ -0,0 +1,35 @@
|
|||||||
|
#!/usr/bin/perl
|
||||||
|
|
||||||
|
use 5.018;
|
||||||
|
use strict;
|
||||||
|
use warnings "all";
|
||||||
|
use utf8;
|
||||||
|
use open qw(:std :utf8);
|
||||||
|
|
||||||
|
use lib ("./lib", "./vendor_perl", "./vendor_perl/lib/perl5");
|
||||||
|
|
||||||
|
use JSON::PP;
|
||||||
|
|
||||||
|
my $c = "data/config.json";
|
||||||
|
open (C, "<", $c) or die "No conf at $c: $!\n";
|
||||||
|
my $len = (stat ($c)) [7];
|
||||||
|
my $json;
|
||||||
|
my $readlen = read (C, $json, $len);
|
||||||
|
|
||||||
|
unless ($readlen) {
|
||||||
|
close C;
|
||||||
|
die "Unable to read $c: $!\n";
|
||||||
|
}
|
||||||
|
|
||||||
|
if ($readlen != $len) {
|
||||||
|
close C;
|
||||||
|
die "File $c is $len bytes on disk, but we read only $readlen bytes\n";
|
||||||
|
}
|
||||||
|
|
||||||
|
close C;
|
||||||
|
$c = decode_json ($json);
|
||||||
|
|
||||||
|
my $j = JSON::PP->new->pretty->canonical->indent_length (4);
|
||||||
|
print $j->encode ($c);
|
||||||
|
|
||||||
|
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||||
14
cpanfile
Normal file
14
cpanfile
Normal file
@@ -0,0 +1,14 @@
|
|||||||
|
requires 'Cwd::utf8';
|
||||||
|
requires 'DB_File';
|
||||||
|
requires 'Digest::MD5';
|
||||||
|
requires 'File::Basename';
|
||||||
|
requires 'File::Path';
|
||||||
|
requires 'HTTP::Tiny';
|
||||||
|
requires 'Hailo';
|
||||||
|
requires 'JSON';
|
||||||
|
requires 'JSON::XS';
|
||||||
|
requires 'JSON::PP';
|
||||||
|
requires 'Net::Jabber::Bot';
|
||||||
|
requires 'POSIX';
|
||||||
|
requires 'URI::URL';
|
||||||
|
requires 'local::lib';
|
||||||
24
data/sample_config.json
Normal file
24
data/sample_config.json
Normal file
@@ -0,0 +1,24 @@
|
|||||||
|
{
|
||||||
|
"user" : "nobody",
|
||||||
|
"jabberbot": {
|
||||||
|
# maybe onece it will be multi-instance of bot
|
||||||
|
"aleesa" : {
|
||||||
|
"state" : "enabled",
|
||||||
|
"host" : "jabber.ru",
|
||||||
|
"confsrv": "conference.jabber.ru",
|
||||||
|
# sadly, but for now we can serve only one room
|
||||||
|
"room" : "mychatroom",
|
||||||
|
"authname" : "mybot",
|
||||||
|
"mucname" : "mybot",
|
||||||
|
"password": "mypassword",
|
||||||
|
"brain": "data/aleesa.jabber.sqlite",
|
||||||
|
"csign": "!"
|
||||||
|
},
|
||||||
|
},
|
||||||
|
"openweathermap" : {
|
||||||
|
"cachetime": "data/cache/openweathermap.Id-Timestamp.db",
|
||||||
|
"cachedata": "data/cache/openweathermap.Id-Data.db",
|
||||||
|
"appid": "get_it_on_openweathermap.org"
|
||||||
|
},
|
||||||
|
"debug_log" : "/var/log/aleesa-telegram-bot/debug.log"
|
||||||
|
}
|
||||||
238
lib/botlib.pm
Normal file
238
lib/botlib.pm
Normal file
@@ -0,0 +1,238 @@
|
|||||||
|
package botlib;
|
||||||
|
|
||||||
|
use 5.018;
|
||||||
|
use strict;
|
||||||
|
use warnings "all";
|
||||||
|
use utf8;
|
||||||
|
use open qw(:std :utf8);
|
||||||
|
|
||||||
|
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 vars qw/$VERSION/;
|
||||||
|
|
||||||
|
use Exporter qw(import);
|
||||||
|
our @EXPORT = qw(weather logger trim randomCommonPhrase);
|
||||||
|
|
||||||
|
$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 {
|
||||||
|
warn "Something nasty happen when cachetime ties to its data: $!";
|
||||||
|
return undef;
|
||||||
|
};
|
||||||
|
|
||||||
|
tie my %cachedata, 'DB_File', $c->{openweathermap}->{cachedata} or do {
|
||||||
|
warn "Something nasty happen when cachedata ties to its data: $!";
|
||||||
|
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 (my $counter = 0; $counter < 3; $counter++) {
|
||||||
|
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 ($@) {
|
||||||
|
warn "[WARN] openweathermap returns corrupted json: $@";
|
||||||
|
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 logger {
|
||||||
|
my $msg = shift;
|
||||||
|
|
||||||
|
if ($c->{debug_log}) {
|
||||||
|
my $mode = '>';
|
||||||
|
$mode = '>>' if (-f $c->{debug_log});
|
||||||
|
|
||||||
|
if (open (LOG, $mode, $c->{debug_log})) {
|
||||||
|
print LOG $msg . "\n";
|
||||||
|
close LOG;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
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 = (
|
||||||
|
"Так, блядь...",
|
||||||
|
"*Закатывает рукава* И ради этого ты меня позвал?",
|
||||||
|
"Ну чего ты начинаешь, нормально же общались",
|
||||||
|
"Повтори свой вопрос, не поняла",
|
||||||
|
"Выйди и зайди нормально",
|
||||||
|
"Я подумаю",
|
||||||
|
"Даже не знаю что на это ответить",
|
||||||
|
"Ты упал такие вопросы девочке задавать?",
|
||||||
|
"Можно и так, но не уверена",
|
||||||
|
"А как ты думаешь?"
|
||||||
|
);
|
||||||
|
|
||||||
|
return ($myphrase[rand($#myphrase -1)]);
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
||||||
|
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||||
69
lib/conf.pm
Normal file
69
lib/conf.pm
Normal file
@@ -0,0 +1,69 @@
|
|||||||
|
package conf;
|
||||||
|
|
||||||
|
use 5.018;
|
||||||
|
use strict;
|
||||||
|
use warnings "all";
|
||||||
|
use utf8;
|
||||||
|
use open qw(:std :utf8);
|
||||||
|
|
||||||
|
use vars qw/$VERSION/;
|
||||||
|
use Fcntl qw(O_WRONLY O_CREAT O_TRUNC);
|
||||||
|
use JSON::XS qw(decode_json encode_json);
|
||||||
|
|
||||||
|
use Exporter qw(import);
|
||||||
|
our @EXPORT = qw(loadConf saveConf);
|
||||||
|
|
||||||
|
$VERSION = "1.0";
|
||||||
|
sub loadConf ();
|
||||||
|
sub saveConf ($);
|
||||||
|
|
||||||
|
sub loadConf () {
|
||||||
|
my $c = "data/config.json";
|
||||||
|
open (C, "<", $c) or die "[FATA] No conf at $c: $!\n";
|
||||||
|
my $len = (stat ($c)) [7];
|
||||||
|
my $json;
|
||||||
|
my $readlen = read (C, $json, $len);
|
||||||
|
|
||||||
|
unless ($readlen) {
|
||||||
|
close C;
|
||||||
|
die "[FATA] Unable to read $c: $!\n";
|
||||||
|
}
|
||||||
|
|
||||||
|
if ($readlen != $len) {
|
||||||
|
close C;
|
||||||
|
die "[FATA] File $c is $len bytes on disk, but we read only $readlen bytes\n";
|
||||||
|
}
|
||||||
|
|
||||||
|
close C;
|
||||||
|
my $j = JSON::XS->new->utf8->relaxed;
|
||||||
|
return $j->decode ($json);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub saveConf($) {
|
||||||
|
my $c = shift;
|
||||||
|
my $file = "data/myapi.json";
|
||||||
|
my $j = JSON::XS->new->pretty->canonical->indent (1);
|
||||||
|
my $json = $j->encode ($c);
|
||||||
|
$j = undef; undef $j;
|
||||||
|
use bytes;
|
||||||
|
my $len = length ($json);
|
||||||
|
no bytes;
|
||||||
|
# TODO: make it transactional
|
||||||
|
sysopen (C, $file, O_WRONLY|O_CREAT|O_TRUNC) or die "[FATA] Unable to open $file: $!\n";
|
||||||
|
|
||||||
|
my $written = syswrite (C, $json, $len);
|
||||||
|
|
||||||
|
unless (defined ($written)) {
|
||||||
|
die "[FATA] Unable to write to $file: $!";
|
||||||
|
}
|
||||||
|
|
||||||
|
unless ($written != $len) {
|
||||||
|
die "[FATA] We wrote $written bytes to $file, bu buffer length id $len bytes\n";
|
||||||
|
}
|
||||||
|
|
||||||
|
close C;
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
||||||
|
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||||
172
lib/jabberbot.pm
Normal file
172
lib/jabberbot.pm
Normal file
@@ -0,0 +1,172 @@
|
|||||||
|
# note http://www.gentoo.ru/node/21449
|
||||||
|
# необходимо закомменировать строку $response{authzid} = $authzid;
|
||||||
|
# в vendor_perl/5.24.3/Authen/SASL/Perl/DIGEST_MD5.pm
|
||||||
|
package jabberbot;
|
||||||
|
|
||||||
|
use 5.018;
|
||||||
|
use strict;
|
||||||
|
use warnings "all";
|
||||||
|
use utf8;
|
||||||
|
use open qw(:std :utf8);
|
||||||
|
|
||||||
|
use Net::Jabber::Bot;
|
||||||
|
use Hailo;
|
||||||
|
|
||||||
|
use conf;
|
||||||
|
use botlib;
|
||||||
|
|
||||||
|
use Exporter qw(import);
|
||||||
|
use vars qw/$VERSION/;
|
||||||
|
$VERSION = "1.0";
|
||||||
|
our @EXPORT = qw(run_jabberbot);
|
||||||
|
|
||||||
|
my $c = loadConf();
|
||||||
|
my $hailo;
|
||||||
|
my $imonline = 0;
|
||||||
|
|
||||||
|
sub __background_checks {
|
||||||
|
my $bot = shift;
|
||||||
|
|
||||||
|
unless ($imonline) {
|
||||||
|
$bot->ChangeStatus('Chat', 'I\'m here');
|
||||||
|
$imonline = 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub __new_bot_message {
|
||||||
|
my %hash = @_;
|
||||||
|
my $bot = $hash{bot_object};
|
||||||
|
# my $text = encode('utf-8', $hash{body});
|
||||||
|
my $text = $hash{body};
|
||||||
|
|
||||||
|
if ($hash{'type'} eq "groupchat") {
|
||||||
|
# ignore self messages
|
||||||
|
return if ($hash{'from_full'} eq $bot->{'from_full'});
|
||||||
|
# parse messages
|
||||||
|
my $qname = quotemeta($c->{jabberbot}->{aleesa}->{mucname});
|
||||||
|
if ($text =~ /^$qname$/) {
|
||||||
|
$bot->SendGroupMessage($hash{'reply_to'}, "Чего тебе?");
|
||||||
|
} elsif ($text =~ /^$qname[\,|\:]? (.+)/) {
|
||||||
|
# $bot->SendGroupMessage($hash{'reply_to'}, $hailo->learn_reply(decode('utf-8', $1)));
|
||||||
|
$bot->SendGroupMessage($hash{'reply_to'}, $hailo->learn_reply($1));
|
||||||
|
} elsif ($text eq "$c->{jabberbot}->{aleesa}->{csign}пинг") {
|
||||||
|
$bot->SendGroupMessage($hash{'reply_to'}, "Понг.");
|
||||||
|
} elsif ($text eq "$c->{jabberbot}->{aleesa}->{csign}ping") {
|
||||||
|
$bot->SendGroupMessage($hash{'reply_to'}, "Pong.");
|
||||||
|
} elsif (substr($text, 0, 1) eq $c->{jabberbot}->{aleesa}->{csign}) {
|
||||||
|
# $text = decode('utf-8', $text);
|
||||||
|
|
||||||
|
if (substr($text, 1, 3) eq "rum") {
|
||||||
|
eval {
|
||||||
|
$bot->SendGroupMessage(
|
||||||
|
$hash{'reply_to'},
|
||||||
|
"/me притаскивает на подносе стопку рома для ". (split(/\//,$hash{from_full}))[1] . ", края стопки искрятся кристаллами соли."
|
||||||
|
);
|
||||||
|
};
|
||||||
|
} elsif (substr($text, 1, 5) eq "vodka") {
|
||||||
|
eval {
|
||||||
|
$bot->SendGroupMessage(
|
||||||
|
$hash{'reply_to'},
|
||||||
|
"/me подаёт водку с маринованным огурчиком для " . (split(/\//,$hash{from_full}))[1]
|
||||||
|
);
|
||||||
|
};
|
||||||
|
} elsif (substr($text, 1, 4) eq "beer") {
|
||||||
|
eval {
|
||||||
|
$bot->SendGroupMessage(
|
||||||
|
$hash{'reply_to'},
|
||||||
|
"/me бахает об стол перед " . (split(/\//,$hash{from_full}))[1] . " кружкой холодного пива, часть пенной шапки сползает по запотевшей спенке кружки."
|
||||||
|
);
|
||||||
|
};
|
||||||
|
} elsif (substr($text, 1, 7) eq "tequila") {
|
||||||
|
eval {
|
||||||
|
$bot->SendGroupMessage(
|
||||||
|
$hash{'reply_to'},
|
||||||
|
"/me ставит рядом с " . (split(/\//,$hash{from_full}))[1] . " шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли."
|
||||||
|
);
|
||||||
|
};
|
||||||
|
} elsif (substr($text, 1, 6) eq "whisky") {
|
||||||
|
eval {
|
||||||
|
$bot->SendGroupMessage(
|
||||||
|
$hash{'reply_to'},
|
||||||
|
"/me демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около " . (split(/\//,$hash{from_full}))[1] . "."
|
||||||
|
);
|
||||||
|
};
|
||||||
|
} elsif (substr($text, 1, 8) eq "absinthe") {
|
||||||
|
eval {
|
||||||
|
$bot->SendGroupMessage(
|
||||||
|
$hash{'reply_to'},
|
||||||
|
"/me наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, $c->{jabberbot}->{aleesa}->{mucname} размешивает оплавившийся кубик в абсенте и подносит стопку " .(split(/\//,$hash{from_full}))[1] . "."
|
||||||
|
);
|
||||||
|
};
|
||||||
|
} elsif ((substr($text, 1, 2) eq "w ") || (substr($text, 1, 2) eq "п ")) {
|
||||||
|
my $city = substr($text, 2);
|
||||||
|
|
||||||
|
eval {
|
||||||
|
$bot->SendGroupMessage(
|
||||||
|
$hash{'reply_to'},
|
||||||
|
weather($city) =~ tr/\n/ /r
|
||||||
|
);
|
||||||
|
};
|
||||||
|
} else {
|
||||||
|
#$hailo->learn($text);
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
} else {
|
||||||
|
#$hailo->learn($text);
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
} elsif ($hash{'type'} eq "chat") {
|
||||||
|
$bot->SendPersonalMessage($hash{'reply_to'}, "Я вас не знаю, идите нахуй.");
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
sub run_jabberbot {
|
||||||
|
$hailo = Hailo->new(
|
||||||
|
brain => $c->{jabberbot}->{aleesa}->{brain},
|
||||||
|
order => 3
|
||||||
|
);
|
||||||
|
|
||||||
|
my %conflist = ();
|
||||||
|
$conflist{$c->{jabberbot}->{aleesa}->{room}} = [];
|
||||||
|
my $qname = quotemeta($c->{jabberbot}->{aleesa}->{mucname});
|
||||||
|
|
||||||
|
my $bot = Net::Jabber::Bot->new(
|
||||||
|
server => $c->{jabberbot}->{aleesa}->{host},
|
||||||
|
server_host => $c->{jabberbot}->{aleesa}->{host},
|
||||||
|
conference_server => $c->{jabberbot}->{aleesa}->{confsrv},
|
||||||
|
tls => 0,
|
||||||
|
username => $c->{jabberbot}->{aleesa}->{authname},
|
||||||
|
# threre is some nasty bug in module, so we have to set from_full explicitly
|
||||||
|
from_full => sprintf(
|
||||||
|
"%s@%s/%s",
|
||||||
|
$c->{jabberbot}->{aleesa}->{room},
|
||||||
|
$c->{jabberbot}->{aleesa}->{confsrv},
|
||||||
|
$c->{jabberbot}->{aleesa}->{authname}
|
||||||
|
),
|
||||||
|
password => $c->{jabberbot}->{aleesa}->{password},
|
||||||
|
alias => $c->{jabberbot}->{aleesa}->{mucname}, # name on confs
|
||||||
|
resource => 'bot',
|
||||||
|
safety_mode => 1,
|
||||||
|
message_function => \&__new_bot_message,
|
||||||
|
background_function => \&__background_checks,
|
||||||
|
loop_sleep_time => 60,
|
||||||
|
forums_and_responses => \%conflist,
|
||||||
|
);
|
||||||
|
|
||||||
|
while (sleep 3) {
|
||||||
|
eval {
|
||||||
|
$imonline = 0;
|
||||||
|
$bot->Start();
|
||||||
|
};
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
||||||
|
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||||
Reference in New Issue
Block a user