lib/App/Statsbot.pm

   1 package App::Statsbot;
   2
   3 use 5.014000;
   4 use strict;
   5 use warnings;
   6
   7 our $VERSION = '0.001002';
   8
   9 use POE;
  10 use POE::Component::IRC::State;
  11 use POE::Component::IRC::Plugin::AutoJoin;
  12 use POE::Component::IRC::Plugin::Connector;
  13 use POE::Component::IRC::Plugin::CTCP;
  14 use IRC::Utils qw/parse_user/;
  15
  16 use Carp;
  17 use DBI;
  18 use DBD::SQLite;
  19 use Text::ParseWords qw/shellwords/;
  20 use Time::Duration qw/duration duration_exact/;
  21 use Time::Duration::Parse qw/parse_duration/;
  22
  23 use List::Util qw/max/;
  24
  25 our $DEBUG = '';
  26 our $TICK  = 10;
  27 our $NICKNAME = 'statsbot';
  28 our $SERVER = 'irc.freenode.net';
  29 our $PORT = 6667;
  30 our $SSL = '';
  31 our @CHANNELS;
  32 our $DB = '/var/lib/statsbot/db';
  33
  34 my $dbh;
  35 my $insert;
  36 my $update;
  37 my $irc;
  38
  39 my %state;
  40
  41 sub _yield { $irc->yield(@_) }
  42 sub _nick_name { $irc->nick_name }
  43
  44 sub _uptime {
  45         my ($starttime, $nick) = @_;
  46         my $sth=$dbh->prepare('SELECT start,end FROM presence WHERE end > ? AND nick == ?');
  47         $sth->execute($starttime, $nick);
  48
  49         my $uptime=0;
  50         while (my ($start, $end)=$sth->fetchrow_array) {
  51                 $uptime+=$end-max($start,$starttime)
  52         }
  53         return $uptime
  54 }
  55
  56 sub run {
  57         $irc=POE::Component::IRC::State->spawn;
  58         POE::Session->create(
  59                 inline_states => {
  60                         _start     => \&bot_start,
  61                         irc_public => \&on_public,
  62
  63                         irc_chan_sync => \&tick,
  64                         tick => \&tick,
  65
  66                         irc_disconnected => \&on_fatal,
  67                         irc_error => \&on_fatal,
  68                 },
  69                 options => { trace => $DEBUG },
  70         );
  71
  72         $dbh=DBI->connect("dbi:SQLite:dbname=$DB") or croak "Cannot connect to database: $!";
  73         $dbh->do('CREATE TABLE presence (start INTEGER, end INTEGER, nick TEXT)');
  74         $insert=$dbh->prepare('INSERT INTO presence (start, end, nick) VALUES (?,?,?)') or croak "Cannot prepare query: $!";
  75         $update=$dbh->prepare('UPDATE presence SET end = ? WHERE start == ? AND nick == ?') or croak "Cannot prepare query: $!";
  76         $poe_kernel->run();
  77 };
  78
  79 sub tick{
  80         my %nicks = map {$_ => 1} $irc->nicks;
  81         for my $nick (keys %state) {
  82                 $update->execute(time, $state{$nick}, $nick);
  83                 delete $state{$nick} unless (exists $nicks{$nick});
  84                 delete $nicks{$nick};
  85         }
  86
  87         for (keys %nicks) {
  88                 $state{$_}=time;
  89                 $insert->execute($state{$_}, $state{$_}, $_);
  90         }
  91         $_[KERNEL]->delay(tick => $TICK);
  92 }
  93
  94 sub bot_start{ ## no critic (RequireArgUnpacking)
  95         $_[KERNEL]->delay(tick => $TICK);
  96
  97         $irc->plugin_add(CTCP => POE::Component::IRC::Plugin::CTCP->new(
  98                 version => "Statsbot/$VERSION",
  99                 source => 'https://metacpan.org/pod/App::Statsbot',
 100                 userinfo => 'A bot which keeps logs and computes channel statistics',
 101                 clientinfo => 'PING VERSION CLIENTINFO USERINFO SOURCE',
 102         ));
 103         $irc->plugin_add(AutoJoin => POE::Component::IRC::Plugin::AutoJoin->new(
 104                 Channels => [ @CHANNELS ],
 105                 RejoinOnKick => 1,
 106                 Rejoin_delay => 20,
 107                 Retry_when_banned => 60,
 108         ));
 109         $irc->plugin_add(Connecter => POE::Component::IRC::Plugin::Connector->new(
 110                 servers => [ $SERVER ],
 111         ));
 112
 113         _yield(register => 'all');
 114         _yield(
 115                 connect => {
 116                         Nick     => $NICKNAME,
 117                         Username => 'statsbot',
 118                         Ircname  => 'Logging and statistics bot',
 119                         Server   => $SERVER,
 120                         Port     => $PORT,
 121                         UseSSL   => $SSL,
 122                 }
 123         );
 124 }
 125
 126 sub on_fatal{ croak "Fatal error: $_[ARG0]" }
 127
 128 sub on_public{
 129         my ($targets,$message)=@_[ARG1,ARG2];
 130         my $botnick = _nick_name;
 131
 132         if ($message =~ /(?:$botnick[:,])?\s*!?help\s*(.*)/sx) {
 133                 _yield(privmsg => $targets, 'Try !presence username interval [truncate]');
 134                 _yield(privmsg => $targets, q/For example, !presence mgv '2 days'/);
 135                 _yield(privmsg => $targets, q/or !presence mgv '1 year' 4/);
 136                 return;
 137         }
 138
 139         return unless $message =~ /(?:$botnick[:,])?\s*!?presence\s*(.*)/sx;
 140         my ($nick, $time, $truncate) = shellwords $1;
 141
 142         $truncate//=-1;
 143
 144         unless (defined $time) {
 145                 $time='1 days';
 146                 $truncate=-1;
 147         }
 148
 149         eval {
 150                 $time = parse_duration $time;
 151         } or do {
 152                 _yield(privmsg => $targets, "cannot parse timespec: $time");
 153                 return;
 154         };
 155
 156         my $uptime=_uptime time-$time, $nick;
 157
 158         my $ret;
 159         if ($truncate == -1) {
 160                 use integer;
 161                 $ret=($uptime/3600).' hours';
 162         } else {
 163                 $ret=duration $uptime,$truncate;
 164         }
 165
 166         $time=duration_exact $time;
 167
 168         _yield(privmsg => $targets, "$nick was here $ret during the last $time");
 169 }
 170
 171
 172 1;
 173 __END__
 174
 175 =encoding utf-8
 176
 177 =head1 NAME
 178
 179 App::Statsbot - simple IRC bot that tracks time spent in a channel
 180
 181 =head1 SYNOPSIS
 182
 183   use App::Statsbot;
 184   @App::Statsbot::CHANNELS = '#oooes';
 185   $App::Statsbot::DEBUG = 1;
 186   App::Statsbot->run
 187
 188   # Bot will respond to queries of the forms:
 189   # < mgv> !presence mgv
 190   # < mgv>   presence mgv '1 day'
 191   # < mgv> BOTNICK: !presence mgv '1 year' 2
 192   # < mgv> BOTNICK:    presence   mgv
 193
 194 =head1 DESCRIPTION
 195
 196 App::Statsbot is a simple IRC bot that tracks the people that inhabit
 197 a channel. It is able to answer queries of the form "In the last <time
 198 interval>, how much time did <nick> spend in this channel?".
 199
 200 It is configured via global variables in the App::Statsbot package.
 201
 202 =over
 203
 204 =item $DEBUG
 205
 206 If true, print some debug information. Defaults to false.
 207
 208 =item $TICK
 209
 210 How often (in seconds) to poll the channel for nicks. Defaults to 10
 211 seconds.
 212
 213 =item $NICKNAME
 214
 215 The nickname of the bot. Defaults to "statsbot".
 216
 217 =item $SERVER
 218
 219 The IRC server. Defaults to "irc.freenode.net".
 220
 221 =item $PORT
 222
 223 The port. Defaults to 6667.
 224
 225 =item $SSL
 226
 227 If true, connect via SSL. Defaults to false.
 228
 229 =item @CHANNELS
 230
 231 Array of channels to connect to. Defaults to an empty array, which is
 232 not very useful.
 233
 234 =item $DB
 235
 236 Path to SQLite database. Must be writable. Will be created if it does
 237 not exist. Defaults to C</var/lib/statsbot/db>.
 238
 239 =back
 240
 241 After configuration, the bot can be started using the B<run> function,
 242 which can be called as either a regular function or a method.
 243
 244 =head1 SEE ALSO
 245
 246 L<statsbot>
 247
 248 =head1 AUTHOR
 249
 250 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
 251
 252 =head1 COPYRIGHT AND LICENSE
 253
 254 Copyright (C) 2013-2015 by Marius Gavrilescu
 255
 256 This library is free software; you can redistribute it and/or modify
 257 it under the same terms as Perl itself, either Perl version 5.20.2 or,
 258 at your option, any later version of Perl 5 you may have available.
 259
 260
 261 =cut