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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26