]>
Commit | Line | Data |
---|---|---|
3cdbe256 MG |
1 | package App::Statsbot; |
2 | ||
3 | use 5.014000; | |
4 | use strict; | |
5 | use warnings; | |
6 | ||
7 | our $VERSION = '0.001'; | |
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 | ||
6e23c401 | 16 | use Carp; |
3cdbe256 MG |
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 | ||
6e23c401 MG |
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 | ||
3cdbe256 MG |
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 | ||
6e23c401 | 72 | $dbh=DBI->connect("dbi:SQLite:dbname=$DB") or croak "Cannot connect to database: $!"; |
3cdbe256 | 73 | $dbh->do('CREATE TABLE presence (start INTEGER, end INTEGER, nick TEXT)'); |
6e23c401 MG |
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: $!"; | |
3cdbe256 MG |
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 | ||
6e23c401 | 94 | sub bot_start{ ## no critic (RequireArgUnpacking) |
3cdbe256 MG |
95 | $_[KERNEL]->delay(tick => $TICK); |
96 | ||
97 | $irc->plugin_add(CTCP => POE::Component::IRC::Plugin::CTCP->new( | |
98 | userinfo => 'A bot which keeps logs and computes channel statistics', | |
99 | clientinfo => 'PING VERSION CLIENTINFO USERINFO SOURCE', | |
100 | )); | |
101 | $irc->plugin_add(AutoJoin => POE::Component::IRC::Plugin::AutoJoin->new( | |
102 | Channels => [ @CHANNELS ], | |
103 | RejoinOnKick => 1, | |
104 | Rejoin_delay => 20, | |
105 | Retry_when_banned => 60, | |
106 | )); | |
107 | $irc->plugin_add(Connecter => POE::Component::IRC::Plugin::Connector->new( | |
108 | servers => [ $SERVER ], | |
109 | )); | |
110 | ||
6e23c401 MG |
111 | _yield(register => 'all'); |
112 | _yield( | |
3cdbe256 MG |
113 | connect => { |
114 | Nick => $NICKNAME, | |
115 | Username => 'statsbot', | |
116 | Ircname => 'Logging and statistics bot', | |
117 | Server => $SERVER, | |
118 | Port => $PORT, | |
119 | UseSSL => $SSL, | |
120 | } | |
121 | ); | |
122 | } | |
123 | ||
6e23c401 | 124 | sub on_fatal{ croak "Fatal error: $_[ARG0]" } |
3cdbe256 MG |
125 | |
126 | sub on_public{ | |
127 | my ($targets,$message)=@_[ARG1,ARG2]; | |
6e23c401 | 128 | my $botnick = _nick_name; |
410c016e MG |
129 | |
130 | if ($message =~ /(?:$botnick[:,])?\s*!?help\s*(.*)/) { | |
6e23c401 MG |
131 | _yield(privmsg => $targets, "Try !presence username interval [truncate]"); |
132 | _yield(privmsg => $targets, "For example, !presence mgv '2 days'"); | |
133 | _yield(privmsg => $targets, "or !presence mgv '1 year' 4"); | |
410c016e MG |
134 | return; |
135 | } | |
136 | ||
6e23c401 | 137 | return unless $message =~ /(?:$botnick[:,])?\s*!?presence\s*(.*)/sx; |
3cdbe256 MG |
138 | my ($nick, $time, $truncate) = shellwords $1; |
139 | ||
140 | $truncate//=-1; | |
141 | ||
142 | unless (defined $time) { | |
143 | $time='1 days'; | |
144 | $truncate=-1; | |
145 | } | |
146 | ||
147 | eval { | |
148 | $time = parse_duration $time; | |
149 | } or do { | |
6e23c401 | 150 | _yield(privmsg => $targets, "cannot parse timespec: $time"); |
3cdbe256 MG |
151 | return; |
152 | }; | |
153 | ||
6e23c401 | 154 | my $uptime=_uptime time-$time, $nick; |
3cdbe256 MG |
155 | |
156 | my $ret; | |
157 | if ($truncate == -1) { | |
158 | use integer; | |
159 | $ret=($uptime/3600).' hours'; | |
160 | } else { | |
161 | $ret=duration $uptime,$truncate; | |
162 | } | |
163 | ||
164 | $time=duration_exact $time; | |
165 | ||
6e23c401 | 166 | _yield(privmsg => $targets, "$nick was here $ret during the last $time"); |
3cdbe256 MG |
167 | } |
168 | ||
169 | ||
170 | 1; | |
171 | __END__ | |
172 | ||
173 | =encoding utf-8 | |
174 | ||
175 | =head1 NAME | |
176 | ||
177 | App::Statsbot - simple IRC bot that tracks time spent in a channel | |
178 | ||
179 | =head1 SYNOPSIS | |
180 | ||
181 | use App::Statsbot; | |
182 | @App::Statsbot::CHANNELS = '#oooes'; | |
183 | $App::Statsbot::DEBUG = 1; | |
184 | App::Statsbot->run | |
185 | ||
186 | # Bot will respond to queries of the forms: | |
187 | # < mgv> !presence mgv | |
188 | # < mgv> presence mgv '1 day' | |
189 | # < mgv> BOTNICK: !presence mgv '1 year' 2 | |
190 | # < mgv> BOTNICK: presence mgv | |
191 | ||
192 | =head1 DESCRIPTION | |
193 | ||
194 | App::Statsbot is a simple IRC bot that tracks the people that inhabit | |
195 | a channel. It is able to answer queries of the form "In the last <time | |
196 | interval>, how much time did <nick> spend in this channel?". | |
197 | ||
198 | It is configured via global variables in the App::Statsbot package. | |
199 | ||
200 | =over | |
201 | ||
202 | =item $DEBUG | |
203 | ||
204 | If true, print some debug information. Defaults to false. | |
205 | ||
206 | =item $TICK | |
207 | ||
208 | How often (in seconds) to poll the channel for nicks. Defaults to 10 | |
209 | seconds. | |
210 | ||
211 | =item $NICKNAME | |
212 | ||
213 | The nickname of the bot. Defaults to "statsbot". | |
214 | ||
215 | =item $SERVER | |
216 | ||
217 | The IRC server. Defaults to "irc.freenode.net". | |
218 | ||
219 | =item $PORT | |
220 | ||
221 | The port. Defaults to 6667. | |
222 | ||
223 | =item $SSL | |
224 | ||
225 | If true, connect via SSL. Defaults to false. | |
226 | ||
227 | =item @CHANNELS | |
228 | ||
229 | Array of channels to connect to. Defaults to an empty array, which is | |
230 | not very useful. | |
231 | ||
232 | =item $DB | |
233 | ||
234 | Path to SQLite database. Must be writable. Will be created if it does | |
235 | not exist. Defaults to C</var/lib/statsbot/db>. | |
236 | ||
237 | =back | |
238 | ||
239 | After configuration, the bot can be started using the B<run> function, | |
240 | which can be called as either a regular function or a method. | |
241 | ||
242 | =head1 SEE ALSO | |
243 | ||
244 | L<statsbot> | |
245 | ||
246 | =head1 AUTHOR | |
247 | ||
248 | Marius Gavrilescu, E<lt>marius@ieval.roE<gt> | |
249 | ||
250 | =head1 COPYRIGHT AND LICENSE | |
251 | ||
252 | Copyright (C) 2013-2015 by Marius Gavrilescu | |
253 | ||
254 | This library is free software; you can redistribute it and/or modify | |
255 | it under the same terms as Perl itself, either Perl version 5.20.2 or, | |
256 | at your option, any later version of Perl 5 you may have available. | |
257 | ||
258 | ||
259 | =cut |