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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26