/[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 116 - (show annotations)
Wed Mar 12 17:21:07 2008 UTC (16 years ago) by dpavlin
File MIME type: text/plain
File size: 34033 byte(s)
- _log will now dump() args which are structures
- freenode seems to insert binary junk in messages, so ignore it
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 my ( $total, $updates ) = ( 0, 0 );
669 for my $entry ($feed->entries) {
670 $total++;
671
672 # seen allready?
673 next if $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++ > 0;
674
675 sub prefix {
676 my ($txt,$var) = @_;
677 $var =~ s/\s+/ /gs;
678 $var =~ s/^\s+//g;
679 $var =~ s/\s+$//g;
680 return $txt . $var if $var;
681 }
682
683 # fix absolute and relative links to feed entries
684 my $link = $entry->link;
685 if ( $link =~ m!^/! ) {
686 my $host = $args->{url};
687 $host =~ s!^(http://[^/]+).*$!$1!; #!vim
688 $link = "$host/$link";
689 } elsif ( $link !~ m!^http! ) {
690 $link = $args->{url} . $link;
691 }
692
693 my $msg;
694 $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
695 $msg .= prefix( ' by ' , $entry->author );
696 $msg .= prefix( ' | ' , $entry->title );
697 $msg .= prefix( ' | ' , $link );
698 # $msg .= prefix( ' id ' , $entry->id );
699 if ( my $tags = $entry->category ) {
700 $tags =~ s!^\s+!!;
701 $tags =~ s!\s*$! !;
702 $tags =~ s!\s+!// !g;
703 $msg .= prefix( ' ' , $tags );
704 }
705
706 if ( $args->{kernel} && $send_rss_msgs ) {
707 $send_rss_msgs--;
708 if ( ! $args->{private} ) {
709 # FIXME bug! should be save_message
710 # save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
711 $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
712 }
713 my ( $type, $to ) = ( 'notice', $args->{channel} );
714 ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
715 _log(">> $type $to", $msg);
716 $args->{kernel}->post( $irc => $type => $to, $msg );
717 $updates++;
718 }
719 }
720
721 my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
722 $sql .= qq{, updates = updates + $updates } if $updates;
723 $sql .= qq{where id = } . $args->{id};
724 eval { $dbh->do( $sql ) };
725
726 _log "RSS got $total items of which $updates new";
727
728 return $updates;
729 }
730
731 sub rss_fetch_all {
732 my $kernel = shift;
733 my $sql = qq{
734 select id, url, name, channel, nick, private
735 from feeds
736 where active is true
737 };
738 # limit to newer feeds only if we are not sending messages out
739 $sql .= qq{ and last_update + delay < now() } if $kernel;
740 my $sth = $dbh->prepare( $sql );
741 $sth->execute();
742 warn "# ",$sth->rows," active RSS feeds\n";
743 my $count = 0;
744 while (my $row = $sth->fetchrow_hashref) {
745 $row->{kernel} = $kernel if $kernel;
746 $count += rss_fetch( $row );
747 }
748 return "OK, fetched $count posts from " . $sth->rows . " feeds";
749 }
750
751
752 sub rss_check_updates {
753 my $kernel = shift;
754 $_stat->{rss}->{last_poll} ||= time();
755 my $dt = time() - $_stat->{rss}->{last_poll};
756 warn "## rss_check_updates $dt > $rss_min_delay\n";
757 if ( $dt > $rss_min_delay ) {
758 $_stat->{rss}->{last_poll} = time();
759 _log rss_fetch_all( $kernel );
760 }
761 }
762
763 # seed rss seen cache so we won't send out all items on startup
764 _log rss_fetch_all;
765
766 POE::Session->create( inline_states => {
767 _start => sub {
768 $_[KERNEL]->post( $irc => register => 'all' );
769 $_[KERNEL]->post( $irc => connect => {} );
770 },
771 irc_001 => sub {
772 my ($kernel,$sender) = @_[KERNEL,SENDER];
773 my $poco_object = $sender->get_heap();
774 _log "connected to",$poco_object->server_name();
775 $kernel->post( $sender => join => $_ ) for @channels;
776 undef;
777 },
778 irc_255 => sub { # server is done blabbing
779 $_[KERNEL]->post( $irc => join => $CHANNEL);
780 },
781 irc_public => sub {
782 my $kernel = $_[KERNEL];
783 my $nick = (split /!/, $_[ARG0])[0];
784 my $channel = $_[ARG1]->[0];
785 my $msg = $_[ARG2];
786
787 save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
788 meta( $nick, $channel, 'last-msg', $msg );
789 rss_check_updates( $kernel );
790 },
791 irc_ctcp_action => sub {
792 my $kernel = $_[KERNEL];
793 my $nick = (split /!/, $_[ARG0])[0];
794 my $channel = $_[ARG1]->[0];
795 my $msg = $_[ARG2];
796
797 save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
798
799 if ( $use_twitter ) {
800 if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
801 my ($login,$passwd) = split(/\s+/,$twitter,2);
802 _log("sending twitter for $nick/$login on $channel ");
803 my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
804 $bot->update("<${channel}> $msg");
805 }
806 }
807
808 },
809 irc_ping => sub {
810 _log( "pong ", $_[ARG0] );
811 $_stat->{ping}->{ $_[ARG0] }++;
812 rss_check_updates( $_[KERNEL] );
813 },
814 irc_invite => sub {
815 my $kernel = $_[KERNEL];
816 my $nick = (split /!/, $_[ARG0])[0];
817 my $channel = $_[ARG1];
818
819 _log "invited to $channel by $nick";
820
821 $_[KERNEL]->post( $irc => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
822 $_[KERNEL]->post( $irc => 'join' => $channel );
823
824 },
825 irc_msg => sub {
826 my $kernel = $_[KERNEL];
827 my $nick = (split /!/, $_[ARG0])[0];
828 my $msg = $_[ARG2];
829 my $channel = $_[ARG1]->[0];
830
831 my $res = "unknown command '$msg', try /msg $NICK help!";
832 my @out;
833
834 _log "<< $msg";
835
836 if ($msg =~ m/^help/i) {
837
838 $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
839
840 } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
841
842 _log ">> /$1 $2 $3";
843 $_[KERNEL]->post( $irc => $1 => $2, $3 );
844 $res = '';
845
846 } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
847
848 my $nr = $1 || 10;
849
850 my $sth = $dbh->prepare(qq{
851 select
852 trim(both '_' from nick) as nick,
853 count(*) as count,
854 sum(length(message)) as len
855 from log
856 group by trim(both '_' from nick)
857 order by len desc,count desc
858 limit $nr
859 });
860 $sth->execute();
861 $res = "Top $nr users: ";
862 my @users;
863 while (my $row = $sth->fetchrow_hashref) {
864 push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
865 }
866 $res .= join(" | ", @users);
867 } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
868
869 my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
870
871 foreach my $res (get_from_log( limit => $limit )) {
872 _log "last: $res";
873 $_[KERNEL]->post( $irc => privmsg => $nick, $res );
874 }
875
876 $res = '';
877
878 } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
879
880 my $what = $2;
881
882 foreach my $res (get_from_log(
883 limit => 20,
884 search => $what,
885 )) {
886 _log "search [$what]: $res";
887 $_[KERNEL]->post( $irc => privmsg => $nick, $res );
888 }
889
890 $res = '';
891
892 } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
893
894 my ($what,$limit) = ($1,$2);
895 $limit ||= 100;
896
897 my $stat;
898
899 foreach my $res (get_from_log(
900 limit => $limit,
901 search => $what,
902 full_rows => 1,
903 )) {
904 while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
905 $stat->{vote}->{$1}++;
906 $stat->{from}->{ $res->{nick} }++;
907 }
908 }
909
910 my @nicks;
911 foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
912 push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
913 "(" . $stat->{from}->{$nick} . ")"
914 );
915 }
916
917 $res =
918 "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
919 " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
920 " from " . ( join(", ", @nicks) || 'nobody' );
921
922 $_[KERNEL]->post( $irc => notice => $nick, $res );
923
924 } elsif ($msg =~ m/^ping/) {
925 $res = "ping = " . dump( $_stat->{ping} );
926 } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
927 if ( ! defined( $1 ) ) {
928 my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
929 $sth->execute( $nick, $channel );
930 $res = "config for $nick on $channel";
931 while ( my ($n,$v) = $sth->fetchrow_array ) {
932 $res .= " | $n = $v";
933 }
934 } elsif ( ! $2 ) {
935 my $val = meta( $nick, $channel, $1 );
936 $res = "current $1 = " . ( $val ? $val : 'undefined' );
937 } else {
938 my $validate = {
939 'last-size' => qr/^\d+/,
940 'twitter' => qr/^\w+\s+\w+/,
941 };
942
943 my ( $op, $val ) = ( $1, $2 );
944
945 if ( my $regex = $validate->{$op} ) {
946 if ( $val =~ $regex ) {
947 meta( $nick, $channel, $op, $val );
948 $res = "saved $op = $val";
949 } else {
950 $res = "config option $op = $val doesn't validate against $regex";
951 }
952 } else {
953 $res = "config option $op doesn't exist";
954 }
955 }
956 } elsif ($msg =~ m/^rss-update/) {
957 $res = rss_fetch_all( $_[KERNEL] );
958 } elsif ($msg =~ m/^rss-clean/) {
959 $_stat->{rss} = undef;
960 $dbh->do( qq{ update feeds set last_update = now() - delay } );
961 $res = "OK, cleaned RSS cache";
962 } elsif ($msg =~ m/^rss-list/) {
963 my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
964 $sth->execute;
965 while (my @row = $sth->fetchrow_array) {
966 $_[KERNEL]->post( $irc => privmsg => $nick, join(' | ',@row) );
967 }
968 $res = '';
969 } elsif ($msg =~ m!^rss-(add|remove|stop|start)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
970 my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
971
972 my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
973 $channel = $nick if $sub eq 'private';
974
975 my $sql = {
976 add => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
977 # remove => qq{ delete from feeds where url = ? and name = ? },
978 start => qq{ update feeds set active = true where url = ? },
979 stop => qq{ update feeds set active = false where url = ? },
980 };
981
982 if ( $command eq 'add' && ! $channel ) {
983 $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
984 } elsif (my $q = $sql->{$command} ) {
985 my $sth = $dbh->prepare( $q );
986 my @data = ( $url );
987 if ( $command eq 'add' ) {
988 push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
989 }
990 warn "## $command SQL $q with ",dump( @data ),"\n";
991 eval { $sth->execute( @data ) };
992 if ($@) {
993 $res = "ERROR: $@";
994 } else {
995 $res = "OK, RSS [$command|$sub|$url|$arg]";
996 }
997 } else {
998 $res = "ERROR: don't know what to do with: $msg";
999 }
1000 }
1001
1002 if ($res) {
1003 _log ">> [$nick] $res";
1004 $_[KERNEL]->post( $irc => privmsg => $nick, $res );
1005 }
1006
1007 rss_check_updates( $_[KERNEL] );
1008 },
1009 irc_372 => sub {
1010 _log "<< motd",$_[ARG0],$_[ARG1];
1011 },
1012 irc_375 => sub {
1013 _log "<< motd", $_[ARG0], "start";
1014 },
1015 irc_376 => sub {
1016 _log "<< motd", $_[ARG0], "end";
1017 },
1018 # irc_433 => sub {
1019 # print "# irc_433: ",$_[ARG1], "\n";
1020 # warn "## indetify $NICK\n";
1021 # $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1022 # },
1023 # irc_451 # please register
1024 irc_477 => sub {
1025 _log "<< irc_477: ",$_[ARG1];
1026 _log ">> IDENTIFY $NICK";
1027 $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1028 },
1029 irc_505 => sub {
1030 _log "<< irc_505: ",$_[ARG1];
1031 _log ">> register $NICK";
1032 $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1033 # $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1034 # $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1035 # $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1036 },
1037 irc_registered => sub {
1038 _log "<< registered $NICK";
1039 },
1040 irc_disconnected => sub {
1041 _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1042 sleep($sleep_on_error);
1043 $_[KERNEL]->post( $irc => connect => {} );
1044 },
1045 irc_socketerr => sub {
1046 _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1047 sleep($sleep_on_error);
1048 $_[KERNEL]->post( $irc => connect => {} );
1049 },
1050 irc_notice => sub {
1051 _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1052 my $m = $_[ARG2];
1053 if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1054 _log ">> suggested to $1 $2";
1055 $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1056 } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1057 _log ">> registreted, so IDENTIFY";
1058 $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1059 } else {
1060 warn "## ignore $m\n";
1061 }
1062 },
1063 irc_snotice => sub {
1064 _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1065 if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1066 warn ">> $1 | $2\n";
1067 $_[KERNEL]->post( $irc => lc($1) => $2);
1068 }
1069 },
1070 _child => sub {},
1071 _default => sub {
1072 _log sprintf "sID:%s %s %s",
1073 $_[SESSION]->ID, $_[ARG0],
1074 ref($_[ARG1]) eq "ARRAY" ? join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] }) :
1075 $_[ARG1] ? $_[ARG1] :
1076 "";
1077 0; # false for signals
1078 },
1079 },
1080 );
1081
1082 # http server
1083
1084 _log "WEB archive at $url";
1085
1086 my $httpd = POE::Component::Server::HTTP->new(
1087 Port => $http_port,
1088 PreHandler => {
1089 '/' => sub {
1090 $_[0]->header(Connection => 'close')
1091 }
1092 },
1093 ContentHandler => { '/' => \&root_handler },
1094 Headers => { Server => 'irc-logger' },
1095 );
1096
1097 my $style = <<'_END_OF_STYLE_';
1098 p { margin: 0; padding: 0.1em; }
1099 .time, .channel { color: #808080; font-size: 60%; }
1100 .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
1101 .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
1102 .message { color: #000000; font-size: 100%; }
1103 .search { float: right; }
1104 a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1105 a:hover.tag { border: 1px solid #eee }
1106 hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1107 /*
1108 .col-0 { background: #ffff66 }
1109 .col-1 { background: #a0ffff }
1110 .col-2 { background: #99ff99 }
1111 .col-3 { background: #ff9999 }
1112 .col-4 { background: #ff66ff }
1113 */
1114 .calendar { border: 1px solid red; width: 100%; }
1115 .month { border: 0px; width: 100%; }
1116 _END_OF_STYLE_
1117
1118 $max_color = 0;
1119
1120 my @cols = qw(
1121 #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1122 #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1123 #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1124 #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1125 #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1126 );
1127
1128 foreach my $c (@cols) {
1129 $style .= ".col-${max_color} { background: $c }\n";
1130 $max_color++;
1131 }
1132 _log "WEB defined $max_color colors for users...";
1133
1134 sub root_handler {
1135 my ($request, $response) = @_;
1136 $response->code(RC_OK);
1137
1138 # this doesn't seem to work, so moved to PreHandler
1139 #$response->header(Connection => 'close');
1140
1141 return RC_OK if $request->uri =~ m/favicon.ico$/;
1142
1143 my $q;
1144
1145 if ( $request->method eq 'POST' ) {
1146 $q = new CGI::Simple( $request->content );
1147 } elsif ( $request->uri =~ /\?(.+)$/ ) {
1148 $q = new CGI::Simple( $1 );
1149 } else {
1150 $q = new CGI::Simple;
1151 }
1152
1153 my $search = $q->param('search') || $q->param('grep') || '';
1154 my $r_url = $request->url;
1155
1156 my @commands = qw( tags last-tag follow stat );
1157 my $commands_re = join('|',@commands);
1158
1159 if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1160 my $show = lc($1);
1161 my $nr = $2;
1162
1163 my $type = 'RSS'; # Atom
1164
1165 $response->content_type( 'application/' . lc($type) . '+xml' );
1166
1167 my $html = '<!-- error -->';
1168 #warn "create $type feed from ",dump( @last_tags );
1169
1170 my $feed = XML::Feed->new( $type );
1171 $feed->link( $url );
1172
1173 my $rc = RC_OK;
1174
1175 if ( $show eq 'tags' ) {
1176 $nr ||= 50;
1177 $feed->title( "tags from $CHANNEL" );
1178 $feed->link( "$url/tags" );
1179 $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1180 my $feed_entry = XML::Feed::Entry->new($type);
1181 $feed_entry->title( "$nr tags from $CHANNEL" );
1182 $feed_entry->author( $NICK );
1183 $feed_entry->link( '/#tags' );
1184
1185 $feed_entry->content(
1186 qq{<![CDATA[<style type="text/css">}
1187 . $cloud->css
1188 . qq{</style>}
1189 . $cloud->html( $nr )
1190 . qq{]]>}
1191 );
1192 $feed->add_entry( $feed_entry );
1193
1194 } elsif ( $show eq 'last-tag' ) {
1195
1196 $nr ||= $last_x_tags;
1197 $nr = $last_x_tags if $nr > $last_x_tags;
1198
1199 $feed->title( "last $nr tagged messages from $CHANNEL" );
1200 $feed->description( "collects messages which have tags// in them" );
1201
1202 foreach my $m ( @last_tags ) {
1203 # warn dump( $m );
1204 #my $tags = join(' ', @{$m->{tags}} );
1205 my $feed_entry = XML::Feed::Entry->new($type);
1206 $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1207 $feed_entry->author( $m->{nick} );
1208 $feed_entry->link( '/#' . $m->{id} );
1209 $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1210
1211 my $message = $filter->{message}->( $m->{message} );
1212 $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1213 # warn "## message = $message\n";
1214
1215 #$feed_entry->summary(
1216 $feed_entry->content(
1217 "<![CDATA[$message]]>"
1218 );
1219 $feed_entry->category( join(', ', @{$m->{tags}}) );
1220 $feed->add_entry( $feed_entry );
1221
1222 $nr--;
1223 last if $nr <= 0;
1224
1225 }
1226
1227 } elsif ( $show =~ m/^follow/ ) {
1228
1229 $feed->title( "Feeds which this bot follows" );
1230
1231 my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1232 $sth->execute;
1233 while (my $row = $sth->fetchrow_hashref) {
1234 my $feed_entry = XML::Feed::Entry->new($type);
1235 $feed_entry->title( $row->{name} );
1236 $feed_entry->link( $row->{url} );
1237 $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1238 $feed_entry->content(
1239 '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1240 );
1241 $feed->add_entry( $feed_entry );
1242 }
1243
1244 } elsif ( $show =~ m/^stat/ ) {
1245
1246 my $feed_entry = XML::Feed::Entry->new($type);
1247 $feed_entry->title( "Internal stats" );
1248 $feed_entry->content(
1249 '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1250 );
1251 $feed->add_entry( $feed_entry );
1252
1253 } else {
1254 _log "WEB unknown rss request $r_url";
1255 $feed->title( "unknown $r_url" );
1256 foreach my $c ( @commands ) {
1257 my $feed_entry = XML::Feed::Entry->new($type);
1258 $feed_entry->title( "rss/$c" );
1259 $feed_entry->link( "$url/rss/$c" );
1260 $feed->add_entry( $feed_entry );
1261 }
1262 $rc = RC_DENY;
1263 }
1264
1265 $response->content( $feed->as_xml );
1266 return $rc;
1267 }
1268
1269 if ( $@ ) {
1270 warn "$@";
1271 }
1272
1273 $response->content_type("text/html; charset=UTF-8");
1274
1275 my $html =
1276 qq{<html><head><title>$NICK</title><style type="text/css">$style}
1277 . $cloud->css
1278 . qq{</style></head><body>}
1279 . qq{
1280 <form method="post" class="search" action="/">
1281 <input type="text" name="search" value="$search" size="10">
1282 <input type="submit" value="search">
1283 </form>
1284 }
1285 . $cloud->html(500)
1286 . qq{<p>};
1287
1288 if ($request->url =~ m#/tags?#) {
1289 # nop
1290 } elsif ($request->url =~ m#/history#) {
1291 my $sth = $dbh->prepare(qq{
1292 select date(time) as date,count(*) as nr,sum(length(message)) as len
1293 from log
1294 group by date(time)
1295 order by date(time) desc
1296 });
1297 $sth->execute();
1298 my ($l_yyyy,$l_mm) = (0,0);
1299 $html .= qq{<table class="calendar"><tr>};
1300 my $cal;
1301 my $ord = 0;
1302 while (my $row = $sth->fetchrow_hashref) {
1303 # this is probably PostgreSQL specific, expects ISO date
1304 my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1305 if ($yyyy != $l_yyyy || $mm != $l_mm) {
1306 if ( $cal ) {
1307 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1308 $ord++;
1309 $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1310 }
1311 $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1312 $cal->border(1);
1313 $cal->width('30%');
1314 $cal->cellheight('5em');
1315 $cal->tableclass('month');
1316 #$cal->cellclass('day');
1317 $cal->sunday('SUN');
1318 $cal->saturday('SAT');
1319 $cal->weekdays('MON','TUE','WED','THU','FRI');
1320 ($l_yyyy,$l_mm) = ($yyyy,$mm);
1321 }
1322 $cal->setcontent($dd, qq[
1323 <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1324 ]) if $cal;
1325
1326 }
1327 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1328
1329 } else {
1330 $html .= join("</p><p>",
1331 get_from_log(
1332 limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1333 search => $search || undef,
1334 tag => $q->param('tag') || undef,
1335 date => $q->param('date') || undef,
1336 fmt => {
1337 date => sub {
1338 my $date = shift || return;
1339 qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1340 },
1341 time => '<span class="time">%s</span> ',
1342 time_channel => '<span class="channel">%s %s</span> ',
1343 nick => '%s:&nbsp;',
1344 me_nick => '***%s&nbsp;',
1345 message => '<span class="message">%s</span>',
1346 },
1347 filter => $filter,
1348 )
1349 );
1350 }
1351
1352 $html .= qq{</p>
1353 <hr/>
1354 <p>See <a href="/history">history</a> of all messages.</p>
1355 </body></html>};
1356
1357 $response->content( $html );
1358 warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1359 return RC_OK;
1360 }
1361
1362 POE::Kernel->run;

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26