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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26