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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26