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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26