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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26