/[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 114 - (show annotations)
Mon Mar 10 21:52:49 2008 UTC (12 years, 5 months ago) by dpavlin
File MIME type: text/plain
File size: 33753 byte(s)
few changes all other the place:
- convert RSS category into tags// for archive
- reorder irc_\d+ functions and correct registration sequence for freenode
- prefix WEB before web related output
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 open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";
116
117 sub _log {
118 print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;
119 }
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",$_[ARG0],dump($_[ARG1]);
1052 if ( $_[ARG0] =~ m!/msg\s+NickServ\s+IDENTIFY!i ) {
1053 _log ">> IDENTIFY";
1054 $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1055 }
1056 },
1057 irc_snotice => sub {
1058 _log "<< snotice",$_[ARG0];
1059 if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1060 warn ">> $1 | $2\n";
1061 $_[KERNEL]->post( $irc => lc($1) => $2);
1062 }
1063 },
1064 _child => sub {},
1065 _default => sub {
1066 _log sprintf "sID:%s %s %s",
1067 $_[SESSION]->ID, $_[ARG0],
1068 ref($_[ARG1]) eq "ARRAY" ? join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] }) :
1069 $_[ARG1] ? $_[ARG1] :
1070 "";
1071 0; # false for signals
1072 },
1073 },
1074 );
1075
1076 # http server
1077
1078 _log "WEB archive at $url";
1079
1080 my $httpd = POE::Component::Server::HTTP->new(
1081 Port => $http_port,
1082 PreHandler => {
1083 '/' => sub {
1084 $_[0]->header(Connection => 'close')
1085 }
1086 },
1087 ContentHandler => { '/' => \&root_handler },
1088 Headers => { Server => 'irc-logger' },
1089 );
1090
1091 my $style = <<'_END_OF_STYLE_';
1092 p { margin: 0; padding: 0.1em; }
1093 .time, .channel { color: #808080; font-size: 60%; }
1094 .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
1095 .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
1096 .message { color: #000000; font-size: 100%; }
1097 .search { float: right; }
1098 a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1099 a:hover.tag { border: 1px solid #eee }
1100 hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1101 /*
1102 .col-0 { background: #ffff66 }
1103 .col-1 { background: #a0ffff }
1104 .col-2 { background: #99ff99 }
1105 .col-3 { background: #ff9999 }
1106 .col-4 { background: #ff66ff }
1107 */
1108 .calendar { border: 1px solid red; width: 100%; }
1109 .month { border: 0px; width: 100%; }
1110 _END_OF_STYLE_
1111
1112 $max_color = 0;
1113
1114 my @cols = qw(
1115 #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1116 #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1117 #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1118 #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1119 #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1120 );
1121
1122 foreach my $c (@cols) {
1123 $style .= ".col-${max_color} { background: $c }\n";
1124 $max_color++;
1125 }
1126 _log "WEB defined $max_color colors for users...";
1127
1128 sub root_handler {
1129 my ($request, $response) = @_;
1130 $response->code(RC_OK);
1131
1132 # this doesn't seem to work, so moved to PreHandler
1133 #$response->header(Connection => 'close');
1134
1135 return RC_OK if $request->uri =~ m/favicon.ico$/;
1136
1137 my $q;
1138
1139 if ( $request->method eq 'POST' ) {
1140 $q = new CGI::Simple( $request->content );
1141 } elsif ( $request->uri =~ /\?(.+)$/ ) {
1142 $q = new CGI::Simple( $1 );
1143 } else {
1144 $q = new CGI::Simple;
1145 }
1146
1147 my $search = $q->param('search') || $q->param('grep') || '';
1148 my $r_url = $request->url;
1149
1150 my @commands = qw( tags last-tag follow stat );
1151 my $commands_re = join('|',@commands);
1152
1153 if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1154 my $show = lc($1);
1155 my $nr = $2;
1156
1157 my $type = 'RSS'; # Atom
1158
1159 $response->content_type( 'application/' . lc($type) . '+xml' );
1160
1161 my $html = '<!-- error -->';
1162 #warn "create $type feed from ",dump( @last_tags );
1163
1164 my $feed = XML::Feed->new( $type );
1165 $feed->link( $url );
1166
1167 my $rc = RC_OK;
1168
1169 if ( $show eq 'tags' ) {
1170 $nr ||= 50;
1171 $feed->title( "tags from $CHANNEL" );
1172 $feed->link( "$url/tags" );
1173 $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1174 my $feed_entry = XML::Feed::Entry->new($type);
1175 $feed_entry->title( "$nr tags from $CHANNEL" );
1176 $feed_entry->author( $NICK );
1177 $feed_entry->link( '/#tags' );
1178
1179 $feed_entry->content(
1180 qq{<![CDATA[<style type="text/css">}
1181 . $cloud->css
1182 . qq{</style>}
1183 . $cloud->html( $nr )
1184 . qq{]]>}
1185 );
1186 $feed->add_entry( $feed_entry );
1187
1188 } elsif ( $show eq 'last-tag' ) {
1189
1190 $nr ||= $last_x_tags;
1191 $nr = $last_x_tags if $nr > $last_x_tags;
1192
1193 $feed->title( "last $nr tagged messages from $CHANNEL" );
1194 $feed->description( "collects messages which have tags// in them" );
1195
1196 foreach my $m ( @last_tags ) {
1197 # warn dump( $m );
1198 #my $tags = join(' ', @{$m->{tags}} );
1199 my $feed_entry = XML::Feed::Entry->new($type);
1200 $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1201 $feed_entry->author( $m->{nick} );
1202 $feed_entry->link( '/#' . $m->{id} );
1203 $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1204
1205 my $message = $filter->{message}->( $m->{message} );
1206 $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1207 # warn "## message = $message\n";
1208
1209 #$feed_entry->summary(
1210 $feed_entry->content(
1211 "<![CDATA[$message]]>"
1212 );
1213 $feed_entry->category( join(', ', @{$m->{tags}}) );
1214 $feed->add_entry( $feed_entry );
1215
1216 $nr--;
1217 last if $nr <= 0;
1218
1219 }
1220
1221 } elsif ( $show =~ m/^follow/ ) {
1222
1223 $feed->title( "Feeds which this bot follows" );
1224
1225 my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1226 $sth->execute;
1227 while (my $row = $sth->fetchrow_hashref) {
1228 my $feed_entry = XML::Feed::Entry->new($type);
1229 $feed_entry->title( $row->{name} );
1230 $feed_entry->link( $row->{url} );
1231 $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1232 $feed_entry->content(
1233 '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1234 );
1235 $feed->add_entry( $feed_entry );
1236 }
1237
1238 } elsif ( $show =~ m/^stat/ ) {
1239
1240 my $feed_entry = XML::Feed::Entry->new($type);
1241 $feed_entry->title( "Internal stats" );
1242 $feed_entry->content(
1243 '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1244 );
1245 $feed->add_entry( $feed_entry );
1246
1247 } else {
1248 _log "WEB unknown rss request $r_url";
1249 $feed->title( "unknown $r_url" );
1250 foreach my $c ( @commands ) {
1251 my $feed_entry = XML::Feed::Entry->new($type);
1252 $feed_entry->title( "rss/$c" );
1253 $feed_entry->link( "$url/rss/$c" );
1254 $feed->add_entry( $feed_entry );
1255 }
1256 $rc = RC_DENY;
1257 }
1258
1259 $response->content( $feed->as_xml );
1260 return $rc;
1261 }
1262
1263 if ( $@ ) {
1264 warn "$@";
1265 }
1266
1267 $response->content_type("text/html; charset=UTF-8");
1268
1269 my $html =
1270 qq{<html><head><title>$NICK</title><style type="text/css">$style}
1271 . $cloud->css
1272 . qq{</style></head><body>}
1273 . qq{
1274 <form method="post" class="search" action="/">
1275 <input type="text" name="search" value="$search" size="10">
1276 <input type="submit" value="search">
1277 </form>
1278 }
1279 . $cloud->html(500)
1280 . qq{<p>};
1281
1282 if ($request->url =~ m#/tags?#) {
1283 # nop
1284 } elsif ($request->url =~ m#/history#) {
1285 my $sth = $dbh->prepare(qq{
1286 select date(time) as date,count(*) as nr,sum(length(message)) as len
1287 from log
1288 group by date(time)
1289 order by date(time) desc
1290 });
1291 $sth->execute();
1292 my ($l_yyyy,$l_mm) = (0,0);
1293 $html .= qq{<table class="calendar"><tr>};
1294 my $cal;
1295 my $ord = 0;
1296 while (my $row = $sth->fetchrow_hashref) {
1297 # this is probably PostgreSQL specific, expects ISO date
1298 my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1299 if ($yyyy != $l_yyyy || $mm != $l_mm) {
1300 if ( $cal ) {
1301 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1302 $ord++;
1303 $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1304 }
1305 $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1306 $cal->border(1);
1307 $cal->width('30%');
1308 $cal->cellheight('5em');
1309 $cal->tableclass('month');
1310 #$cal->cellclass('day');
1311 $cal->sunday('SUN');
1312 $cal->saturday('SAT');
1313 $cal->weekdays('MON','TUE','WED','THU','FRI');
1314 ($l_yyyy,$l_mm) = ($yyyy,$mm);
1315 }
1316 $cal->setcontent($dd, qq[
1317 <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1318 ]) if $cal;
1319
1320 }
1321 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1322
1323 } else {
1324 $html .= join("</p><p>",
1325 get_from_log(
1326 limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1327 search => $search || undef,
1328 tag => $q->param('tag') || undef,
1329 date => $q->param('date') || undef,
1330 fmt => {
1331 date => sub {
1332 my $date = shift || return;
1333 qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1334 },
1335 time => '<span class="time">%s</span> ',
1336 time_channel => '<span class="channel">%s %s</span> ',
1337 nick => '%s:&nbsp;',
1338 me_nick => '***%s&nbsp;',
1339 message => '<span class="message">%s</span>',
1340 },
1341 filter => $filter,
1342 )
1343 );
1344 }
1345
1346 $html .= qq{</p>
1347 <hr/>
1348 <p>See <a href="/history">history</a> of all messages.</p>
1349 </body></html>};
1350
1351 $response->content( $html );
1352 warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1353 return RC_OK;
1354 }
1355
1356 POE::Kernel->run;

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26