/[irc-logger]/trunk/bin/irc-logger.pl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /trunk/bin/irc-logger.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 17 - (show annotations)
Mon Mar 13 16:50:07 2006 UTC (18 years ago) by dpavlin
Original Path: trunk/irc-logger.pl
File MIME type: text/plain
File size: 10948 byte(s)
fix display of search results

1 #!/usr/bin/perl -w
2 use strict;
3 $|++;
4
5 =head1 NAME
6
7 irc-logger.pl
8
9 =head1 SYNOPSIS
10
11 ./irc-logger.pl
12
13 =head1 DESCRIPTION
14
15 log all conversation on irc channel
16
17 =cut
18
19 ## CONFIG
20
21 my $NICK = 'irc-logger-dev';
22 my $CONNECT =
23 {Server => 'irc.freenode.net',
24 Nick => $NICK,
25 Ircname => "try /msg $NICK help",
26 };
27 my $CHANNEL = '#razmjenavjestina';
28 my $IRC_ALIAS = "log";
29
30 my %FOLLOWS =
31 (
32 ACCESS => "/var/log/apache/access.log",
33 ERROR => "/var/log/apache/error.log",
34 );
35
36 my $DSN = 'DBI:Pg:dbname=irc-logger';
37
38 my $ENCODING = 'ISO-8859-2';
39
40 ## END CONFIG
41
42
43
44 use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);
45 use HTTP::Status;
46 use DBI;
47 use Encode qw/from_to/;
48 use Regexp::Common qw /URI/;
49 use CGI::Simple;
50
51
52 my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
53
54 =for SQL schema
55
56 $dbh->do(qq{
57 create table log (
58 id serial,
59 time timestamp default now(),
60 channel text not null,
61 nick text not null,
62 message text not null,
63 primary key(id)
64 );
65
66 create index log_time on log(time);
67 create index log_channel on log(channel);
68 create index log_nick on log(nick);
69
70 });
71
72 =cut
73
74 my $sth = $dbh->prepare(qq{
75 insert into log
76 (channel, nick, message)
77 values (?,?,?)
78 });
79
80 =head2 get_from_log
81
82 my @messages = get_from_log(
83 limit => 42,
84 search => '%what to stuff in ilike%',
85 fmt => {
86 time => '{%s} ',
87 time_channel => '{%s %s} ',
88 nick => '%s: ',
89 message => '%s',
90 },
91 message_filter => sub {
92 # modify message content
93 return shift;
94 }
95 );
96
97 =cut
98
99 sub get_from_log {
100 my $args = {@_};
101
102 $args->{limit} ||= 10;
103
104 $args->{fmt} ||= {
105 time => '{%s} ',
106 time_channel => '{%s %s} ',
107 nick => '%s: ',
108 message => '%s',
109 };
110
111 my $sql = qq{
112 select
113 time::date as date,
114 time::time as time,
115 channel,
116 nick,
117 message
118 from log
119 };
120 $sql .= " where message ilike ? " if ($args->{search});
121 $sql .= " order by log.time desc";
122 $sql .= " limit " . $args->{limit};
123
124 my $sth = $dbh->prepare( $sql );
125 if ($args->{search}) {
126 $sth->execute( '%' . $args->{search} . '%' );
127 warn "search for '$args->{search}' returned ", $sth->rows, " results\n";
128 } else {
129 $sth->execute();
130 }
131 my $last_row = {
132 date => '',
133 time => '',
134 channel => '',
135 nick => '',
136 };
137
138 my @rows;
139
140 while (my $row = $sth->fetchrow_hashref) {
141 unshift @rows, $row;
142 }
143
144 my @msgs = (
145 "Showing " . ($#rows + 1) . " messages..."
146 );
147
148 foreach my $row (@rows) {
149
150 $row->{time} =~ s#\.\d+##;
151
152 my $t;
153 $t = $row->{date} . ' ' if ($last_row->{date} ne $row->{date});
154 $t .= $row->{time};
155
156 my $msg = '';
157
158 if ($last_row->{channel} ne $row->{channel}) {
159 $msg .= sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
160 } else {
161 $msg .= sprintf($args->{fmt}->{time}, $t);
162 }
163
164 my $append = 1;
165
166 if ($last_row->{nick} ne $row->{nick}) {
167 $msg .= sprintf($args->{fmt}->{nick}, $row->{nick});
168 $append = 0;
169 }
170
171 if (ref($args->{message_filter}) eq 'CODE') {
172 $msg .= sprintf($args->{fmt}->{message},
173 $args->{message_filter}->(
174 $row->{message}
175 )
176 );
177 } else {
178 $msg .= sprintf($args->{fmt}->{message}, $row->{message});
179 }
180
181 if ($append && @msgs) {
182 $msgs[$#msgs] .= " " . $msg;
183 } else {
184 push @msgs, $msg;
185 }
186
187 $last_row = $row;
188 }
189
190 return @msgs;
191 }
192
193
194 my $SKIPPING = 0; # if skipping, how many we've done
195 my $SEND_QUEUE; # cache
196
197 POE::Component::IRC->new($IRC_ALIAS);
198
199 POE::Session->create
200 (inline_states =>
201 {_start => sub {
202 $_[KERNEL]->post($IRC_ALIAS => register => 'all');
203 $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
204 },
205 irc_255 => sub { # server is done blabbing
206 $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
207 $_[KERNEL]->post($IRC_ALIAS => join => '#logger');
208 $_[KERNEL]->yield("heartbeat"); # start heartbeat
209 # $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;
210 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
211 },
212 irc_public => sub {
213 my $kernel = $_[KERNEL];
214 my $nick = (split /!/, $_[ARG0])[0];
215 my $channel = $_[ARG1]->[0];
216 my $msg = $_[ARG2];
217
218 from_to($msg, 'UTF-8', $ENCODING);
219
220 print "$channel: <$nick> $msg\n";
221 $sth->execute($channel, $nick, $msg);
222 },
223 irc_msg => sub {
224 my $kernel = $_[KERNEL];
225 my $nick = (split /!/, $_[ARG0])[0];
226 my $msg = $_[ARG2];
227 from_to($msg, 'UTF-8', $ENCODING);
228
229 my $res = "unknown command '$msg', try /msg $NICK help!";
230 my @out;
231
232 print "<< $msg\n";
233
234 if ($msg =~ m/^help/i) {
235
236 $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
237
238 } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
239
240 print ">> /msg $1 $2\n";
241 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
242 $res = '';
243
244 } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
245
246 my $nr = $1 || 10;
247
248 my $sth = $dbh->prepare(qq{
249 select nick,count(*) from log group by nick order by count desc limit $nr
250 });
251 $sth->execute();
252 $res = "Top $nr users: ";
253 my @users;
254 while (my $row = $sth->fetchrow_hashref) {
255 push @users,$row->{nick} . ': ' . $row->{count};
256 }
257 $res .= join(" | ", @users);
258 } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
259
260 foreach my $res (get_from_log( limit => $1 )) {
261 print "last: $res\n";
262 from_to($res, $ENCODING, 'UTF-8');
263 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
264 }
265
266 $res = '';
267
268 } elsif ($msg =~ m/^(search|grep)\s+(.*)$/i) {
269
270 my $what = $2;
271
272 foreach my $res (get_from_log( limit => 20, search => $what )) {
273 print "search [$what]: $res\n";
274 from_to($res, $ENCODING, 'UTF-8');
275 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
276 }
277
278 $res = '';
279
280 }
281
282 if ($res) {
283 print ">> [$nick] $res\n";
284 from_to($res, $ENCODING, 'UTF-8');
285 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
286 }
287
288 },
289 irc_477 => sub {
290 print "# irc_477: ",$_[ARG1], "\n";
291 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
292 },
293 irc_505 => sub {
294 print "# irc_505: ",$_[ARG1], "\n";
295 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
296 # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
297 # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
298 },
299 irc_registered => sub {
300 warn "## indetify $NICK\n";
301 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
302 },
303 # irc_433 => sub {
304 # print "# irc_433: ",$_[ARG1], "\n";
305 # warn "## indetify $NICK\n";
306 # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
307 # },
308 irc_372 => sub {
309 print "MOTD: ", $_[ARG1], "\n";
310 },
311 irc_snotice => sub {
312 print "(server notice): ", $_[ARG0], "\n";
313 },
314 (map
315 {
316 ;"irc_$_" => sub { }}
317 qw(
318 )),
319 # join
320 # ctcp_version
321 # connected snotice ctcp_action ping notice mode part quit
322 # 001 002 003 004 005
323 # 250 251 252 253 254 265 266
324 # 332 333 353 366 372 375 376
325 # 477
326 _child => sub {},
327 _default => sub {
328 printf "%s: session %s caught an unhandled %s event.\n",
329 scalar localtime(), $_[SESSION]->ID, $_[ARG0];
330 print "The $_[ARG0] event was given these parameters: ",
331 join(" ", map({"ARRAY" eq ref $_ ? "[@$_]" : "$_"} @{$_[ARG1]})), "\n";
332 0; # false for signals
333 },
334 my_add => sub {
335 my $trailing = $_[ARG0];
336 my $session = $_[SESSION];
337 POE::Session->create
338 (inline_states =>
339 {_start => sub {
340 $_[HEAP]->{wheel} =
341 POE::Wheel::FollowTail->new
342 (
343 Filename => $FOLLOWS{$trailing},
344 InputEvent => 'got_line',
345 );
346 },
347 got_line => sub {
348 $_[KERNEL]->post($session => my_tailed =>
349 time, $trailing, $_[ARG0]);
350 },
351 },
352 );
353
354 },
355 my_tailed => sub {
356 my ($time, $file, $line) = @_[ARG0..ARG2];
357 ## $time will be undef on a probe, or a time value if a real line
358
359 ## PoCo::IRC has throttling built in, but no external visibility
360 ## so this is reaching "under the hood"
361 $SEND_QUEUE ||=
362 $_[KERNEL]->alias_resolve($IRC_ALIAS)->get_heap->{send_queue};
363
364 ## handle "no need to keep skipping" transition
365 if ($SKIPPING and @$SEND_QUEUE < 1) {
366 $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>
367 "[discarded $SKIPPING messages]");
368 $SKIPPING = 0;
369 }
370
371 ## handle potential message display
372 if ($time) {
373 if ($SKIPPING or @$SEND_QUEUE > 3) { # 3 msgs per 10 seconds
374 $SKIPPING++;
375 } else {
376 my @time = localtime $time;
377 $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>
378 sprintf "%02d:%02d:%02d: %s: %s",
379 ($time[2] + 11) % 12 + 1, $time[1], $time[0],
380 $file, $line);
381 }
382 }
383
384 ## handle re-probe/flush if skipping
385 if ($SKIPPING) {
386 $_[KERNEL]->delay($_[STATE] => 0.5); # $time will be undef
387 }
388
389 },
390 my_heartbeat => sub {
391 $_[KERNEL]->yield(my_tailed => time, "heartbeat", "beep");
392 $_[KERNEL]->delay($_[STATE] => 10);
393 }
394 },
395 );
396
397 # http server
398
399 my $httpd = POE::Component::Server::HTTP->new(
400 Port => $NICK =~ m/-dev/ ? 8001 : 8000,
401 ContentHandler => { '/' => \&root_handler },
402 Headers => { Server => 'irc-logger' },
403 );
404
405 my $style = <<'_END_OF_STYLE_';
406 p { margin: 0; padding: 0.1em; }
407 .time, .channel { color: #808080; font-size: 60%; }
408 .nick { color: #0000ff; font-size: 80%; }
409 .message { color: #000000; font-size: 100%; }
410 .search { float: right; }
411 _END_OF_STYLE_
412
413 sub root_handler {
414 my ($request, $response) = @_;
415 $response->code(RC_OK);
416 $response->content_type("text/html; charset=$ENCODING");
417
418 my $q;
419
420 if ( $request->method eq 'POST' ) {
421 $q = new CGI::Simple( $request->content );
422 } elsif ( $request->uri =~ /\?(.+)$/ ) {
423 $q = new CGI::Simple( $1 );
424 } else {
425 $q = new CGI::Simple;
426 }
427
428 my $search = $q->param('search') || $q->param('grep') || '';
429
430 $response->content(
431 qq{<html><head><title>$NICK</title><style type="text/css">$style</style></head><body>
432 <form method="post" class="search">
433 <input type="text" name="search" value="$search" size="10">
434 <input type="submit" value="search">
435 </form>
436 <p>
437 } .
438 join("</p><p>",
439 get_from_log(
440 limit => $q->param('limit') || 100,
441 search => $q->param('search') || $q->param('grep') || undef,
442 fmt => {
443 time => '<span class="time">%s</span> ',
444 time_channel => '<span class="channel">%s %s</span> ',
445 nick => '<span class="nick">%s:</span> ',
446 message => '<span class="message">%s</span>',
447 },
448 message_filter => sub {
449 my $m = shift || return;
450 $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;
451 return $m;
452 },
453 )
454 ) .
455 qq{</p></body></html>}
456 );
457 return RC_OK;
458 }
459
460 POE::Kernel->run;

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26