/[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 58 - (show annotations)
Sat Apr 7 21:08:34 2007 UTC (16 years, 11 months ago) by dpavlin
File MIME type: text/plain
File size: 23584 byte(s)
bug fix: transfer correct values to twitter
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 =head2 Options
14
15 =over 4
16
17 =item --import-dircproxy=filename
18
19 Import log from C<dircproxy> to C<irc-logger> database
20
21 =item --log=irc-logger.log
22
23 Name of log file
24
25 =back
26
27 =head1 DESCRIPTION
28
29 log all conversation on irc channel
30
31 =cut
32
33 ## CONFIG
34
35 my $HOSTNAME = `hostname`;
36
37 my $NICK = 'irc-logger';
38 $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);
39 my $CONNECT =
40 {Server => 'irc.freenode.net',
41 Nick => $NICK,
42 Ircname => "try /msg $NICK help",
43 };
44 my $CHANNEL = '#razmjenavjestina';
45 $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);
46 my $IRC_ALIAS = "log";
47
48 my %FOLLOWS =
49 (
50 ACCESS => "/var/log/apache/access.log",
51 ERROR => "/var/log/apache/error.log",
52 );
53
54 my $DSN = 'DBI:Pg:dbname=' . $NICK;
55
56 my $ENCODING = 'ISO-8859-2';
57 my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
58
59 my $sleep_on_error = 5;
60
61 ## END CONFIG
62
63
64
65 use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);
66 use HTTP::Status;
67 use DBI;
68 use Encode qw/from_to is_utf8/;
69 use Regexp::Common qw /URI/;
70 use CGI::Simple;
71 use HTML::TagCloud;
72 use POSIX qw/strftime/;
73 use HTML::CalendarMonthSimple;
74 use Getopt::Long;
75 use DateTime;
76 use Data::Dump qw/dump/;
77
78 my $use_twitter = 1;
79 eval { require Net::Twitter; };
80 $use_twitter = 0 if ($@);
81
82 my $import_dircproxy;
83 my $log_path;
84 GetOptions(
85 'import-dircproxy:s' => \$import_dircproxy,
86 'log:s' => \$log_path,
87 );
88
89 open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";
90
91 sub _log {
92 print strftime($TIMESTAMP,localtime()), ' ', join(" ",@_), $/;
93 }
94
95 my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
96
97 my $sql_schema = {
98 log => '
99 create table log (
100 id serial,
101 time timestamp default now(),
102 channel text not null,
103 me boolean default false,
104 nick text not null,
105 message text not null,
106 primary key(id)
107 );
108
109 create index log_time on log(time);
110 create index log_channel on log(channel);
111 create index log_nick on log(nick);
112 ',
113 meta => '
114 create table meta (
115 nick text not null,
116 channel text not null,
117 name text not null,
118 value text,
119 changed timestamp default now(),
120 primary key(nick,channel,name)
121 );
122 ',
123 };
124
125 foreach my $table ( keys %$sql_schema ) {
126
127 eval {
128 $dbh->do(qq{ select count(*) from $table });
129 };
130
131 if ($@) {
132 warn "creating database table $table in $DSN\n";
133 $dbh->do( $sql_schema->{ $table } );
134 }
135 }
136
137
138 =head2 meta
139
140 Set or get some meta data into database
141
142 meta('nick','channel','var_name', $var_value );
143
144 $var_value = meta('nick','channel','var_name');
145 ( $var_value, $changed ) = meta('nick','channel','var_name');
146
147 =cut
148
149 sub meta {
150 my ($nick,$channel,$name,$value) = @_;
151
152 # normalize channel name
153 $channel =~ s/^#//;
154
155 if (defined($value)) {
156
157 my $sth = $dbh->prepare(qq{ update meta set value = ?, changed = now() where nick = ? and channel = ? and name = ? });
158
159 eval { $sth->execute( $value, $nick, $channel, $name ) };
160
161 # error or no result
162 if ( $@ || ! $sth->rows ) {
163 $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
164 $sth->execute( $value, $nick, $channel, $name );
165 _log "created $nick/$channel/$name = $value";
166 } else {
167 _log "updated $nick/$channel/$name = $value ";
168 }
169
170 return $value;
171
172 } else {
173
174 my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });
175 $sth->execute( $nick, $channel, $name );
176 my ($v,$c) = $sth->fetchrow_array;
177 _log "fetched $nick/$channel/$name = $v [$c]";
178 return ($v,$c) if wantarray;
179 return $v;
180
181 }
182 }
183
184
185
186 my $sth = $dbh->prepare(qq{
187 insert into log
188 (channel, me, nick, message, time)
189 values (?,?,?,?,?)
190 });
191
192
193 my $tags;
194 my $tag_regex = '\b([\w-_]+)//';
195
196 =head2 get_from_log
197
198 my @messages = get_from_log(
199 limit => 42,
200 search => '%what to stuff in ilike%',
201 fmt => {
202 time => '{%s} ',
203 time_channel => '{%s %s} ',
204 nick => '%s: ',
205 me_nick => '***%s ',
206 message => '%s',
207 },
208 filter => {
209 message => sub {
210 # modify message content
211 return shift;
212 }
213 },
214 context => 5,
215 full_rows => 1,
216 );
217
218 Order is important. Fields are first passed through C<filter> (if available) and
219 then throgh C<< sprintf($fmt->{message}, $message >> if available.
220
221 C<context> defines number of messages around each search hit for display.
222
223 C<full_rows> will return database rows for each result with C<date>, C<time>, C<channel>,
224 C<me>, C<nick> and C<message> keys.
225
226 =cut
227
228 sub get_from_log {
229 my $args = {@_};
230
231 $args->{fmt} ||= {
232 date => '[%s] ',
233 time => '{%s} ',
234 time_channel => '{%s %s} ',
235 nick => '%s: ',
236 me_nick => '***%s ',
237 message => '%s',
238 };
239
240 my $sql_message = qq{
241 select
242 time::date as date,
243 time::time as time,
244 channel,
245 me,
246 nick,
247 message
248 from log
249 };
250
251 my $sql_context = qq{
252 select
253 id
254 from log
255 };
256
257 my $context = $1 if ($args->{search} && $args->{search} =~ s/\s*\+(\d+)\s*/ /);
258
259 my $sql = $context ? $sql_context : $sql_message;
260
261 $sql .= " where message ilike ? or nick ilike ? " if ($args->{search});
262 $sql .= " where id in (" . join(",", @{ $tags->{ $args->{tag} } }) . ") " if ($args->{tag} && $tags->{ $args->{tag} });
263 $sql .= " where date(time) = ? " if ($args->{date});
264 $sql .= " order by log.time desc";
265 $sql .= " limit " . $args->{limit} if ($args->{limit});
266
267 my $sth = $dbh->prepare( $sql );
268 if (my $search = $args->{search}) {
269 $search =~ s/^\s+//;
270 $search =~ s/\s+$//;
271 $sth->execute( ( '%' . $search . '%' ) x 2 );
272 _log "search for '$search' returned ", $sth->rows, " results ", $context || '';
273 } elsif (my $tag = $args->{tag}) {
274 $sth->execute();
275 _log "tag '$tag' returned ", $sth->rows, " results ", $context || '';
276 } elsif (my $date = $args->{date}) {
277 $sth->execute($date);
278 _log "found ", $sth->rows, " messages for date $date ", $context || '';
279 } else {
280 $sth->execute();
281 }
282 my $last_row = {
283 date => '',
284 time => '',
285 channel => '',
286 nick => '',
287 };
288
289 my @rows;
290
291 while (my $row = $sth->fetchrow_hashref) {
292 unshift @rows, $row;
293 }
294
295 # normalize nick names
296 map {
297 $_->{nick} =~ s/^_*(.*?)_*$/$1/
298 } @rows;
299
300 return @rows if ($args->{full_rows});
301
302 my @msgs = (
303 "Showing " . ($#rows + 1) . " messages..."
304 );
305
306 if ($context) {
307 my @ids = @rows;
308 @rows = ();
309
310 my $last_to = 0;
311
312 my $sth = $dbh->prepare( $sql_message . qq{ where id >= ? and id < ? } );
313 foreach my $row_id (sort { $a->{id} <=> $b->{id} } @ids) {
314 my $id = $row_id->{id} || die "can't find id in row";
315
316 my ($from, $to) = ($id - $context, $id + $context);
317 $from = $last_to if ($from < $last_to);
318 $last_to = $to;
319 $sth->execute( $from, $to );
320
321 #warn "## id: $id from: $from to: $to returned: ", $sth->rows, "\n";
322
323 while (my $row = $sth->fetchrow_hashref) {
324 push @rows, $row;
325 }
326
327 }
328 }
329
330 # sprintf which can take coderef as first parametar
331 sub cr_sprintf {
332 my $fmt = shift || return;
333 if (ref($fmt) eq 'CODE') {
334 $fmt->(@_);
335 } else {
336 sprintf($fmt, @_);
337 }
338 }
339
340 foreach my $row (@rows) {
341
342 $row->{time} =~ s#\.\d+##;
343
344 my $msg = '';
345
346 $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
347 my $t = $row->{time};
348
349 if ($last_row->{channel} ne $row->{channel}) {
350 $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
351 } else {
352 $msg .= cr_sprintf($args->{fmt}->{time}, $t);
353 }
354
355 my $append = 1;
356
357 my $nick = $row->{nick};
358 # if ($nick =~ s/^_*(.*?)_*$/$1/) {
359 # $row->{nick} = $nick;
360 # }
361
362 if ($last_row->{nick} ne $nick) {
363 # obfu way to find format for me_nick if needed or fallback to default
364 my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
365 $fmt ||= '%s';
366
367 $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
368
369 $msg .= cr_sprintf( $fmt, $nick );
370 $append = 0;
371 }
372
373 $args->{fmt}->{message} ||= '%s';
374 if (ref($args->{filter}->{message}) eq 'CODE') {
375 $msg .= cr_sprintf($args->{fmt}->{message},
376 $args->{filter}->{message}->(
377 $row->{message}
378 )
379 );
380 } else {
381 $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
382 }
383
384 if ($append && @msgs) {
385 $msgs[$#msgs] .= " " . $msg;
386 } else {
387 push @msgs, $msg;
388 }
389
390 $last_row = $row;
391 }
392
393 return @msgs;
394 }
395
396 # tags support
397
398 my $cloud = HTML::TagCloud->new;
399
400 =head2 add_tag
401
402 add_tag( id => 42, message => 'irc message' );
403
404 =cut
405
406 sub add_tag {
407 my $arg = {@_};
408
409 return unless ($arg->{id} && $arg->{message});
410
411 my $m = $arg->{message};
412 from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));
413
414 while ($m =~ s#$tag_regex##s) {
415 my $tag = $1;
416 next if (! $tag || $tag =~ m/https?:/i);
417 push @{ $tags->{$tag} }, $arg->{id};
418 #warn "+tag $tag: $arg->{id}\n";
419 $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);
420 }
421 }
422
423 =head2 seed_tags
424
425 Read all tags from database and create in-memory cache for tags
426
427 =cut
428
429 sub seed_tags {
430 my $sth = $dbh->prepare(qq{ select id,message from log where message like '%//%' });
431 $sth->execute;
432 while (my $row = $sth->fetchrow_hashref) {
433 add_tag( %$row );
434 }
435
436 foreach my $tag (keys %$tags) {
437 $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);
438 }
439 }
440
441 seed_tags;
442
443
444 =head2 save_message
445
446 save_message(
447 channel => '#foobar',
448 me => 0,
449 nick => 'dpavlin',
450 msg => 'test message',
451 time => '2006-06-25 18:57:18',
452 );
453
454 C<time> is optional, it will use C<< now() >> if it's not available.
455
456 C<me> if not specified will be C<0> (not C</me> message)
457
458 =cut
459
460 sub save_message {
461 my $a = {@_};
462 $a->{me} ||= 0;
463 $a->{time} ||= strftime($TIMESTAMP,localtime());
464
465 _log
466 $a->{channel}, " ",
467 $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
468 " " . $a->{msg};
469
470 from_to($a->{msg}, 'UTF-8', $ENCODING);
471
472 $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{msg}, $a->{time});
473 add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),
474 message => $a->{msg});
475 }
476
477
478 if ($import_dircproxy) {
479 open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
480 warn "importing $import_dircproxy...\n";
481 my $tz_offset = 2 * 60 * 60; # TZ GMT+2
482 while(<$l>) {
483 chomp;
484 if (/^@(\d+)\s(\S+)\s(.+)$/) {
485 my ($time, $nick, $msg) = ($1,$2,$3);
486
487 my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
488
489 my $me = 0;
490 $me = 1 if ($nick =~ m/^\[\S+]/);
491 $nick =~ s/^[\[<]([^!]+).*$/$1/;
492
493 $msg =~ s/^ACTION\s+// if ($me);
494
495 save_message(
496 channel => $CHANNEL,
497 me => $me,
498 nick => $nick,
499 msg => $msg,
500 time => $dt->ymd . " " . $dt->hms,
501 ) if ($nick !~ m/^-/);
502
503 } else {
504 _log "can't parse: $_";
505 }
506 }
507 close($l);
508 warn "import over\n";
509 exit;
510 }
511
512
513 #
514 # POE handing part
515 #
516
517 my $SKIPPING = 0; # if skipping, how many we've done
518 my $SEND_QUEUE; # cache
519 my $ping; # ping stats
520
521 POE::Component::IRC->new($IRC_ALIAS);
522
523 POE::Session->create( inline_states =>
524 {_start => sub {
525 $_[KERNEL]->post($IRC_ALIAS => register => 'all');
526 $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
527 },
528 irc_255 => sub { # server is done blabbing
529 $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
530 $_[KERNEL]->post($IRC_ALIAS => join => '#logger');
531 $_[KERNEL]->yield("heartbeat"); # start heartbeat
532 # $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;
533 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
534 },
535 irc_public => sub {
536 my $kernel = $_[KERNEL];
537 my $nick = (split /!/, $_[ARG0])[0];
538 my $channel = $_[ARG1]->[0];
539 my $msg = $_[ARG2];
540
541 save_message( channel => $channel, me => 0, nick => $nick, msg => $msg);
542 meta( $nick, $channel, 'last-msg', $msg );
543 },
544 irc_ctcp_action => sub {
545 my $kernel = $_[KERNEL];
546 my $nick = (split /!/, $_[ARG0])[0];
547 my $channel = $_[ARG1]->[0];
548 my $msg = $_[ARG2];
549
550 save_message( channel => $channel, me => 1, nick => $nick, msg => $msg);
551
552 if ( $use_twitter ) {
553 if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
554 my ($login,$passwd) = split(/\s+/,$twitter,2);
555 _log("sending twitter for $nick/$login on $channel ");
556 my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
557 $bot->update("<${channel}> $msg");
558 }
559 }
560
561 },
562 irc_ping => sub {
563 warn "pong ", $_[ARG0], $/;
564 $ping->{ $_[ARG0] }++;
565 },
566 irc_invite => sub {
567 my $kernel = $_[KERNEL];
568 my $nick = (split /!/, $_[ARG0])[0];
569 my $channel = $_[ARG1];
570
571 warn "invited to $channel by $nick";
572
573 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
574 $_[KERNEL]->post($IRC_ALIAS => join => $channel);
575
576 },
577 irc_msg => sub {
578 my $kernel = $_[KERNEL];
579 my $nick = (split /!/, $_[ARG0])[0];
580 my $msg = $_[ARG2];
581 my $channel = $_[ARG1]->[0];
582 from_to($msg, 'UTF-8', $ENCODING);
583
584 my $res = "unknown command '$msg', try /msg $NICK help!";
585 my @out;
586
587 _log "<< $msg";
588
589 if ($msg =~ m/^help/i) {
590
591 $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
592
593 } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
594
595 _log ">> /msg $1 $2";
596 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
597 $res = '';
598
599 } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
600
601 my $nr = $1 || 10;
602
603 my $sth = $dbh->prepare(qq{
604 select
605 trim(both '_' from nick) as nick,
606 count(*) as count,
607 sum(length(message)) as len
608 from log
609 group by trim(both '_' from nick)
610 order by len desc,count desc
611 limit $nr
612 });
613 $sth->execute();
614 $res = "Top $nr users: ";
615 my @users;
616 while (my $row = $sth->fetchrow_hashref) {
617 push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
618 }
619 $res .= join(" | ", @users);
620 } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
621
622 my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
623
624 foreach my $res (get_from_log( limit => $limit )) {
625 _log "last: $res";
626 from_to($res, $ENCODING, 'UTF-8');
627 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
628 }
629
630 $res = '';
631
632 } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
633
634 my $what = $2;
635
636 foreach my $res (get_from_log(
637 limit => 20,
638 search => $what,
639 )) {
640 _log "search [$what]: $res";
641 from_to($res, $ENCODING, 'UTF-8');
642 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
643 }
644
645 $res = '';
646
647 } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
648
649 my ($what,$limit) = ($1,$2);
650 $limit ||= 100;
651
652 my $stat;
653
654 foreach my $res (get_from_log(
655 limit => $limit,
656 search => $what,
657 full_rows => 1,
658 )) {
659 while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
660 $stat->{vote}->{$1}++;
661 $stat->{from}->{ $res->{nick} }++;
662 }
663 }
664
665 my @nicks;
666 foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
667 push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
668 "(" . $stat->{from}->{$nick} . ")"
669 );
670 }
671
672 $res =
673 "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
674 " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
675 " from " . ( join(", ", @nicks) || 'nobody' );
676
677 $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );
678
679 } elsif ($msg =~ m/^ping/) {
680 $res = "ping = " . dump( $ping );
681 } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
682 if ( ! defined( $1 ) ) {
683 my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
684 $sth->execute( $nick, $channel );
685 $res = "config for $nick on $channel";
686 while ( my ($n,$v) = $sth->fetchrow_array ) {
687 $res .= " | $n = $v";
688 }
689 } elsif ( ! $2 ) {
690 my $val = meta( $nick, $channel, $1 );
691 $res = "current $1 = " . ( $val ? $val : 'undefined' );
692 } else {
693 my $validate = {
694 'last-size' => qr/^\d+/,
695 'twitter' => qr/^\w+\s+\w+/,
696 };
697
698 my ( $op, $val ) = ( $1, $2 );
699
700 if ( my $regex = $validate->{$op} ) {
701 if ( $val =~ $regex ) {
702 meta( $nick, $channel, $op, $val );
703 $res = "saved $op = $val";
704 } else {
705 $res = "config option $op = $val doesn't validate against $regex";
706 }
707 } else {
708 $res = "config option $op doesn't exist";
709 }
710 }
711 }
712
713 if ($res) {
714 _log ">> [$nick] $res";
715 from_to($res, $ENCODING, 'UTF-8');
716 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
717 }
718
719 },
720 irc_477 => sub {
721 _log "# irc_477: ",$_[ARG1];
722 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
723 },
724 irc_505 => sub {
725 _log "# irc_505: ",$_[ARG1];
726 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
727 # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
728 # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
729 },
730 irc_registered => sub {
731 _log "## registrated $NICK";
732 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
733 },
734 irc_disconnected => sub {
735 _log "## disconnected, reconnecting again";
736 $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
737 },
738 irc_socketerr => sub {
739 _log "## socket error... sleeping for $sleep_on_error seconds and retry";
740 sleep($sleep_on_error);
741 $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
742 },
743 # irc_433 => sub {
744 # print "# irc_433: ",$_[ARG1], "\n";
745 # warn "## indetify $NICK\n";
746 # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
747 # },
748 _child => sub {},
749 _default => sub {
750 _log sprintf "sID:%s %s %s",
751 $_[SESSION]->ID, $_[ARG0],
752 ref($_[ARG1]) eq "ARRAY" ? join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] }) :
753 $_[ARG1] ? $_[ARG1] :
754 "";
755 0; # false for signals
756 },
757 my_add => sub {
758 my $trailing = $_[ARG0];
759 my $session = $_[SESSION];
760 POE::Session->create
761 (inline_states =>
762 {_start => sub {
763 $_[HEAP]->{wheel} =
764 POE::Wheel::FollowTail->new
765 (
766 Filename => $FOLLOWS{$trailing},
767 InputEvent => 'got_line',
768 );
769 },
770 got_line => sub {
771 $_[KERNEL]->post($session => my_tailed =>
772 time, $trailing, $_[ARG0]);
773 },
774 },
775 );
776
777 },
778 my_tailed => sub {
779 my ($time, $file, $line) = @_[ARG0..ARG2];
780 ## $time will be undef on a probe, or a time value if a real line
781
782 ## PoCo::IRC has throttling built in, but no external visibility
783 ## so this is reaching "under the hood"
784 $SEND_QUEUE ||=
785 $_[KERNEL]->alias_resolve($IRC_ALIAS)->get_heap->{send_queue};
786
787 ## handle "no need to keep skipping" transition
788 if ($SKIPPING and @$SEND_QUEUE < 1) {
789 $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>
790 "[discarded $SKIPPING messages]");
791 $SKIPPING = 0;
792 }
793
794 ## handle potential message display
795 if ($time) {
796 if ($SKIPPING or @$SEND_QUEUE > 3) { # 3 msgs per 10 seconds
797 $SKIPPING++;
798 } else {
799 my @time = localtime $time;
800 $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>
801 sprintf "%02d:%02d:%02d: %s: %s",
802 ($time[2] + 11) % 12 + 1, $time[1], $time[0],
803 $file, $line);
804 }
805 }
806
807 ## handle re-probe/flush if skipping
808 if ($SKIPPING) {
809 $_[KERNEL]->delay($_[STATE] => 0.5); # $time will be undef
810 }
811
812 },
813 my_heartbeat => sub {
814 $_[KERNEL]->yield(my_tailed => time, "heartbeat", "beep");
815 $_[KERNEL]->delay($_[STATE] => 10);
816 }
817 },
818 );
819
820 # http server
821
822 my $httpd = POE::Component::Server::HTTP->new(
823 Port => $NICK =~ m/-dev/ ? 8001 : 8000,
824 ContentHandler => { '/' => \&root_handler },
825 Headers => { Server => 'irc-logger' },
826 );
827
828 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
829 my $escape_re = join '|' => keys %escape;
830
831 my $style = <<'_END_OF_STYLE_';
832 p { margin: 0; padding: 0.1em; }
833 .time, .channel { color: #808080; font-size: 60%; }
834 .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
835 .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
836 .message { color: #000000; font-size: 100%; }
837 .search { float: right; }
838 .col-0 { background: #ffff66 }
839 .col-1 { background: #a0ffff }
840 .col-2 { background: #99ff99 }
841 .col-3 { background: #ff9999 }
842 .col-4 { background: #ff66ff }
843 a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
844 a:hover.tag { border: 1px solid #eee }
845 hr { border: 1px dashed #ccc; height: 1px; clear: both; }
846 _END_OF_STYLE_
847
848 my $max_color = 4;
849
850 my %nick_enumerator;
851
852 sub root_handler {
853 my ($request, $response) = @_;
854 $response->code(RC_OK);
855 $response->content_type("text/html; charset=$ENCODING");
856
857 my $q;
858
859 if ( $request->method eq 'POST' ) {
860 $q = new CGI::Simple( $request->content );
861 } elsif ( $request->uri =~ /\?(.+)$/ ) {
862 $q = new CGI::Simple( $1 );
863 } else {
864 $q = new CGI::Simple;
865 }
866
867 my $search = $q->param('search') || $q->param('grep') || '';
868
869 my $html =
870 qq{<html><head><title>$NICK</title><style type="text/css">$style} .
871 $cloud->css .
872 qq{</style></head><body>} .
873 qq{
874 <form method="post" class="search" action="/">
875 <input type="text" name="search" value="$search" size="10">
876 <input type="submit" value="search">
877 </form>
878 } .
879 $cloud->html(500) .
880 qq{<p>};
881 if ($request->url =~ m#/history#) {
882 my $sth = $dbh->prepare(qq{
883 select date(time) as date,count(*) as nr
884 from log
885 group by date(time)
886 order by date(time) desc
887 });
888 $sth->execute();
889 my ($l_yyyy,$l_mm) = (0,0);
890 my $cal;
891 while (my $row = $sth->fetchrow_hashref) {
892 # this is probably PostgreSQL specific, expects ISO date
893 my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
894 if ($yyyy != $l_yyyy || $mm != $l_mm) {
895 $html .= $cal->as_HTML() if ($cal);
896 $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
897 $cal->border(2);
898 ($l_yyyy,$l_mm) = ($yyyy,$mm);
899 }
900 $cal->setcontent($dd, qq{
901 <a href="/?date=$row->{date}">$row->{nr}</a>
902 });
903 }
904 $html .= $cal->as_HTML() if ($cal);
905
906 } else {
907 $html .= join("</p><p>",
908 get_from_log(
909 limit => $q->param('last') || $q->param('date') ? undef : 100,
910 search => $search || undef,
911 tag => $q->param('tag') || undef,
912 date => $q->param('date') || undef,
913 fmt => {
914 date => sub {
915 my $date = shift || return;
916 qq{<hr/><div class="date"><a href="/?date=$date">$date</a></div>};
917 },
918 time => '<span class="time">%s</span> ',
919 time_channel => '<span class="channel">%s %s</span> ',
920 nick => '%s:&nbsp;',
921 me_nick => '***%s&nbsp;',
922 message => '<span class="message">%s</span>',
923 },
924 filter => {
925 message => sub {
926 my $m = shift || return;
927 $m =~ s/($escape_re)/$escape{$1}/gs;
928 $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;
929 $m =~ s#$tag_regex#<a href="?tag=$1" class="tag">$1</a>#g;
930 return $m;
931 },
932 nick => sub {
933 my $n = shift || return;
934 if (! $nick_enumerator{$n}) {
935 my $max = scalar keys %nick_enumerator;
936 $nick_enumerator{$n} = $max + 1;
937 }
938 return '<span class="nick col-' .
939 ( $nick_enumerator{$n} % $max_color ) .
940 '">' . $n . '</span>';
941 },
942 },
943 )
944 );
945 }
946
947 $html .= qq{</p>
948 <hr/>
949 <p>See <a href="/history">history</a> of all messages.</p>
950 </body></html>};
951
952 $response->content( $html );
953 return RC_OK;
954 }
955
956 POE::Kernel->run;

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26