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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26