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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26