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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26