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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26