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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26