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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26