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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26