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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26