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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26