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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26